File : gnatcom-ierrorinfo.adb
------------------------------------------------------------------------------
-- --
-- GNATCOM - Ada 95 COM/DCOM/COM+ Development Framework and Tools --
-- --
-- G N A T C O M . I E R R O R I N F O --
-- --
-- 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.Unchecked_Conversion;
with Interfaces.C;
with GNATCOM.Errors;
with GNATCOM.GUID;
with GNATCOM.BSTR;
package body GNATCOM.IErrorInfo is
type IErrorInfo;
type ICreateErrorInfo;
type ISupportErrorInfo;
type Pointer_To_IErrorInfo is access all IErrorInfo;
type Pointer_To_ICreateErrorInfo is access all ICreateErrorInfo;
type Pointer_To_ISupportErrorInfo is access all ISupportErrorInfo;
-- Element Name : IErrorInfo
-- Element Type : Interface
IID_IErrorInfo : aliased GNATCOM.Types.GUID :=
GNATCOM.GUID.To_GUID ("{1CF2B120-547D-101B-8E65-08002B2BD119}");
type af_IErrorInfo_QueryInterface is access
function (This : access IErrorInfo;
riid : GNATCOM.Types.Pointer_To_GUID;
ppvObj : GNATCOM.Types.Pointer_To_Pointer_To_Void)
return GNATCOM.Types.HRESULT;
pragma Convention (StdCall, af_IErrorInfo_QueryInterface);
type af_IErrorInfo_AddRef is access
function (This : access IErrorInfo)
return Interfaces.C.unsigned_long;
pragma Convention (StdCall, af_IErrorInfo_AddRef);
type af_IErrorInfo_Release is access
function (This : access IErrorInfo)
return Interfaces.C.unsigned_long;
pragma Convention (StdCall, af_IErrorInfo_Release);
type af_IErrorInfo_GetGUID is access
function (This : access IErrorInfo;
pGUID : GNATCOM.Types.Pointer_To_GUID)
return GNATCOM.Types.HRESULT;
pragma Convention (StdCall, af_IErrorInfo_GetGUID);
type af_IErrorInfo_GetSource is access
function (This : access IErrorInfo;
pBstrSource : GNATCOM.Types.Pointer_To_BSTR)
return GNATCOM.Types.HRESULT;
pragma Convention (StdCall, af_IErrorInfo_GetSource);
type af_IErrorInfo_GetDescription is access
function (This : access IErrorInfo;
pBstrDescription : GNATCOM.Types.Pointer_To_BSTR)
return GNATCOM.Types.HRESULT;
pragma Convention (StdCall, af_IErrorInfo_GetDescription);
type af_IErrorInfo_GetHelpFile is access
function (This : access IErrorInfo;
pBstrHelpFile : GNATCOM.Types.Pointer_To_BSTR)
return GNATCOM.Types.HRESULT;
pragma Convention (StdCall, af_IErrorInfo_GetHelpFile);
type af_IErrorInfo_GetHelpContext is access
function (This : access IErrorInfo;
pdwHelpContext : GNATCOM.Types.Pointer_To_unsigned_long)
return GNATCOM.Types.HRESULT;
pragma Convention (StdCall, af_IErrorInfo_GetHelpContext);
type IErrorInfoVtbl;
type Pointer_To_IErrorInfoVtbl is access all IErrorInfoVtbl;
type IErrorInfo is
record
Vtbl : Pointer_To_IErrorInfoVtbl;
end record;
pragma Convention (C_Pass_By_Copy, IErrorInfo);
type IErrorInfoVtbl is
record
QueryInterface : af_IErrorInfo_QueryInterface;
AddRef : af_IErrorInfo_AddRef;
Release : af_IErrorInfo_Release;
GetGUID : af_IErrorInfo_GetGUID;
GetSource : af_IErrorInfo_GetSource;
GetDescription : af_IErrorInfo_GetDescription;
GetHelpFile : af_IErrorInfo_GetHelpFile;
GetHelpContext : af_IErrorInfo_GetHelpContext;
end record;
pragma Convention (C_Pass_By_Copy, IErrorInfoVtbl);
-- function To_Pointer_To_IErrorInfo is
-- new Ada.Unchecked_Conversion
-- (GNATCOM.Types.Pointer_To_Void, Pointer_To_IErrorInfo);
-- Element Name : ICreateErrorInfo
-- Element Type : Interface
-- IID_ICreateErrorInfo : aliased GNATCOM.Types.GUID :=
-- GNATCOM.GUID.To_GUID ("{22F03340-547D-101B-8E65-08002B2BD119}");
type af_ICreateErrorInfo_QueryInterface is access
function (This : access ICreateErrorInfo;
riid : GNATCOM.Types.Pointer_To_GUID;
ppvObj : GNATCOM.Types.Pointer_To_Pointer_To_Void)
return GNATCOM.Types.HRESULT;
pragma Convention (StdCall, af_ICreateErrorInfo_QueryInterface);
type af_ICreateErrorInfo_AddRef is access
function (This : access ICreateErrorInfo)
return Interfaces.C.unsigned_long;
pragma Convention (StdCall, af_ICreateErrorInfo_AddRef);
type af_ICreateErrorInfo_Release is access
function (This : access ICreateErrorInfo)
return Interfaces.C.unsigned_long;
pragma Convention (StdCall, af_ICreateErrorInfo_Release);
type af_ICreateErrorInfo_SetGUID is access
function (This : access ICreateErrorInfo;
rguid : GNATCOM.Types.Pointer_To_GUID)
return GNATCOM.Types.HRESULT;
pragma Convention (StdCall, af_ICreateErrorInfo_SetGUID);
type af_ICreateErrorInfo_SetSource is access
function (This : access ICreateErrorInfo;
szSource : GNATCOM.Types.LPWSTR)
return GNATCOM.Types.HRESULT;
pragma Convention (StdCall, af_ICreateErrorInfo_SetSource);
type af_ICreateErrorInfo_SetDescription is access
function (This : access ICreateErrorInfo;
szDescription : GNATCOM.Types.LPWSTR)
return GNATCOM.Types.HRESULT;
pragma Convention (StdCall, af_ICreateErrorInfo_SetDescription);
type af_ICreateErrorInfo_SetHelpFile is access
function (This : access ICreateErrorInfo;
szHelpFile : GNATCOM.Types.LPWSTR)
return GNATCOM.Types.HRESULT;
pragma Convention (StdCall, af_ICreateErrorInfo_SetHelpFile);
type af_ICreateErrorInfo_SetHelpContext is access
function (This : access ICreateErrorInfo;
dwHelpContext : Interfaces.C.unsigned_long)
return GNATCOM.Types.HRESULT;
pragma Convention (StdCall, af_ICreateErrorInfo_SetHelpContext);
type ICreateErrorInfoVtbl;
type Pointer_To_ICreateErrorInfoVtbl is access all ICreateErrorInfoVtbl;
type ICreateErrorInfo is
record
Vtbl : Pointer_To_ICreateErrorInfoVtbl;
end record;
pragma Convention (C_Pass_By_Copy, ICreateErrorInfo);
type ICreateErrorInfoVtbl is
record
QueryInterface : af_ICreateErrorInfo_QueryInterface;
AddRef : af_ICreateErrorInfo_AddRef;
Release : af_ICreateErrorInfo_Release;
SetGUID : af_ICreateErrorInfo_SetGUID;
SetSource : af_ICreateErrorInfo_SetSource;
SetDescription : af_ICreateErrorInfo_SetDescription;
SetHelpFile : af_ICreateErrorInfo_SetHelpFile;
SetHelpContext : af_ICreateErrorInfo_SetHelpContext;
end record;
pragma Convention (C_Pass_By_Copy, ICreateErrorInfoVtbl);
-- function To_Pointer_To_ICreateErrorInfo is
-- new Ada.Unchecked_Conversion
-- (GNATCOM.Types.Pointer_To_Void, Pointer_To_ICreateErrorInfo);
-- Element Name : ISupportErrorInfo
-- Element Type : Interface
IID_ISupportErrorInfo : aliased GNATCOM.Types.GUID :=
GNATCOM.GUID.To_GUID ("{DF0B3D60-548F-101B-8E65-08002B2BD119}");
type af_ISupportErrorInfo_QueryInterface is access
function (This : access ISupportErrorInfo;
riid : GNATCOM.Types.Pointer_To_GUID;
ppvObj : GNATCOM.Types.Pointer_To_Pointer_To_Void)
return GNATCOM.Types.HRESULT;
pragma Convention (StdCall, af_ISupportErrorInfo_QueryInterface);
type af_ISupportErrorInfo_AddRef is access
function (This : access ISupportErrorInfo)
return Interfaces.C.unsigned_long;
pragma Convention (StdCall, af_ISupportErrorInfo_AddRef);
type af_ISupportErrorInfo_Release is access
function (This : access ISupportErrorInfo)
return Interfaces.C.unsigned_long;
pragma Convention (StdCall, af_ISupportErrorInfo_Release);
type af_ISupportErrorInfo_InterfaceSupportsErrorInfo is access
function (This : access ISupportErrorInfo;
riid : GNATCOM.Types.Pointer_To_GUID)
return GNATCOM.Types.HRESULT;
pragma Convention (StdCall,
af_ISupportErrorInfo_InterfaceSupportsErrorInfo);
type ISupportErrorInfoVtbl;
type Pointer_To_ISupportErrorInfoVtbl is access all ISupportErrorInfoVtbl;
type ISupportErrorInfo is
record
Vtbl : Pointer_To_ISupportErrorInfoVtbl;
end record;
pragma Convention (C_Pass_By_Copy, ISupportErrorInfo);
type ISupportErrorInfoVtbl is
record
QueryInterface : af_ISupportErrorInfo_QueryInterface;
AddRef : af_ISupportErrorInfo_AddRef;
Release : af_ISupportErrorInfo_Release;
InterfaceSupportsErrorInfo :
af_ISupportErrorInfo_InterfaceSupportsErrorInfo;
end record;
pragma Convention (C_Pass_By_Copy, ISupportErrorInfoVtbl);
function To_Pointer_To_ISupportErrorInfo is
new Ada.Unchecked_Conversion
(GNATCOM.Types.Pointer_To_Void, Pointer_To_ISupportErrorInfo);
-----------------------
-- Create_IErrorInfo --
-----------------------
procedure Create_IErrorInfo
(Description : in String;
Source_PROGID : in String := "";
Associated_GUID : in GNATCOM.Types.GUID := GNATCOM.Types.GUID_NULL;
Help_Context : in GNATCOM.Types.DWORD := 0;
Help_File_Path : in String := "")
is
use GNATCOM.Interface;
use GNATCOM.BSTR;
pcerrinfo : aliased Pointer_To_ICreateErrorInfo;
CError_Interface : GNATCOM.Interface.Interface_Type;
Error_Interface : GNATCOM.Interface.Interface_Type;
function CreateErrorInfo
(pperrinfo : access Pointer_To_ICreateErrorInfo)
return GNATCOM.Types.HRESULT;
pragma Import (StdCall, CreateErrorInfo, "CreateErrorInfo");
procedure SetErrorInfo
(Reserverd : Integer := 0;
perrinfo : GNATCOM.Types.Pointer_To_IUnknown);
pragma Import (StdCall, SetErrorInfo, "SetErrorInfo");
Local_GUID : aliased GNATCOM.Types.GUID := Associated_GUID;
BSTR_Source : GNATCOM.Types.BSTR := To_BSTR (Source_PROGID);
BSTR_Description : GNATCOM.Types.BSTR := To_BSTR (Description);
BSTR_Path : GNATCOM.Types.BSTR := To_BSTR (Help_File_Path);
begin
GNATCOM.Errors.Error_Check (CreateErrorInfo (pcerrinfo'Access));
Attach (CError_Interface, pcerrinfo.all'Address);
GNATCOM.Errors.Error_Check
(pcerrinfo.Vtbl.SetGUID (pcerrinfo,
Local_GUID'Unchecked_Access));
GNATCOM.Errors.Error_Check
(pcerrinfo.Vtbl.SetSource (pcerrinfo, BSTR_Source));
GNATCOM.BSTR.Free (BSTR_Source);
GNATCOM.Errors.Error_Check
(pcerrinfo.Vtbl.SetDescription (pcerrinfo, BSTR_Description));
GNATCOM.BSTR.Free (BSTR_Description);
GNATCOM.Errors.Error_Check
(pcerrinfo.Vtbl.SetHelpFile (pcerrinfo,
BSTR_Path));
GNATCOM.BSTR.Free (BSTR_Path);
GNATCOM.Errors.Error_Check
(pcerrinfo.Vtbl.SetHelpContext
(pcerrinfo,
Interfaces.C.unsigned_long (Help_Context)));
Set_IID (Error_Interface, IID_IErrorInfo);
Query (Error_Interface, CError_Interface);
SetErrorInfo (perrinfo => Pointer (Error_Interface));
end Create_IErrorInfo;
--------------------
-- Get_IErrorInfo --
--------------------
function Get_IErrorInfo return String is
use Ada.Strings.Unbounded;
Desc : Ada.Strings.Unbounded.Unbounded_String;
ProgID : Ada.Strings.Unbounded.Unbounded_String;
AGUID : GNATCOM.Types.GUID;
Context : GNATCOM.Types.DWORD;
Path : Ada.Strings.Unbounded.Unbounded_String;
begin
Get_IErrorInfo (Desc, ProgID, AGUID, Context, Path);
return To_String (Desc);
end Get_IErrorInfo;
--------------------
-- Get_IErrorInfo --
--------------------
procedure Get_IErrorInfo
(Description : out Ada.Strings.Unbounded.Unbounded_String;
Source_PROGID : out Ada.Strings.Unbounded.Unbounded_String;
Associated_GUID : out GNATCOM.Types.GUID;
Help_Context : out GNATCOM.Types.DWORD;
Help_File_Path : out Ada.Strings.Unbounded.Unbounded_String)
is
use Ada.Strings.Unbounded;
use GNATCOM.Interface;
use GNATCOM.BSTR;
function GetErrorInfo
(Reserverd : in Integer := 0;
pperrinfo : access Pointer_To_IErrorInfo)
return GNATCOM.Types.HRESULT;
pragma Import (StdCall, GetErrorInfo, "GetErrorInfo");
pErrorInfo : aliased Pointer_To_IErrorInfo;
Error_Interface : GNATCOM.Interface.Interface_Type;
Assoc_GUID : aliased GNATCOM.Types.GUID;
BSTR_Source : aliased GNATCOM.Types.BSTR;
BSTR_Description : aliased GNATCOM.Types.BSTR;
BSTR_Path : aliased GNATCOM.Types.BSTR;
Context : aliased Interfaces.C.unsigned_long;
begin
if
GNATCOM.Errors.Logical_Check
(GetErrorInfo (pperrinfo => pErrorInfo'Access))
then
Attach (Error_Interface, pErrorInfo.all'Address);
GNATCOM.Errors.Error_Check
(pErrorInfo.Vtbl.GetGUID (pErrorInfo, Assoc_GUID'Unchecked_Access));
Associated_GUID := Assoc_GUID;
GNATCOM.Errors.Error_Check
(pErrorInfo.Vtbl.GetSource
(pErrorInfo, BSTR_Source'Unchecked_Access));
Source_PROGID := To_Unbounded_String (To_Ada (BSTR_Source));
GNATCOM.Errors.Error_Check
(pErrorInfo.Vtbl.GetDescription
(pErrorInfo,
BSTR_Description'Unchecked_Access));
Description := To_Unbounded_String (To_Ada (BSTR_Description));
GNATCOM.Errors.Error_Check
(pErrorInfo.Vtbl.GetHelpFile (pErrorInfo,
BSTR_Path'Unchecked_Access));
Help_File_Path := To_Unbounded_String (To_Ada (BSTR_Path));
GNATCOM.Errors.Error_Check
(pErrorInfo.Vtbl.GetHelpContext (pErrorInfo,
Context'Unchecked_Access));
Help_Context := GNATCOM.Types.DWORD (Context);
else
Source_PROGID := To_Unbounded_String ("");
Associated_GUID := GNATCOM.Types.GUID_NULL;
Description := To_Unbounded_String ("");
Help_File_Path := To_Unbounded_String ("");
Help_Context := 0;
end if;
end Get_IErrorInfo;
-------------------------
-- Supports_IErrorInfo --
-------------------------
function Supports_IErrorInfo
(Object : in GNATCOM.Interface.Interface_Type'Class)
return Boolean
is
use GNATCOM.Interface;
Support : GNATCOM.Interface.Interface_Type;
pSupport : Pointer_To_ISupportErrorInfo;
Local_GUID : aliased GNATCOM.Types.GUID := IID (Object);
begin
Set_IID (Support, IID_ISupportErrorInfo);
Query (Support, Object);
pSupport := To_Pointer_To_ISupportErrorInfo (Address (Support));
return GNATCOM.Errors.Logical_Check
(pSupport.Vtbl.InterfaceSupportsErrorInfo
(pSupport,
Local_GUID'Unchecked_Access));
exception
when GNATCOM.Errors.NO_INTERFACE_ERROR =>
return False;
end Supports_IErrorInfo;
end GNATCOM.IErrorInfo;