Working with BSTRs

This package allows easy conversion between null terminated BSTRs and Ada supported types. It should be noted, that it is not possible to create/use non-null terminated BSTRs with this example.

with Win32.OleAuto;
with Interfaces.C;

package BSTR is

   -- These conversion functions create a new BSTR that requires a Free
   -- to destroy
   function To_BSTR( From_Ada : Wide_String ) return Win32.OleAuto.BSTR;
   function To_BSTR( From_Ada : String ) return Win32.OleAuto.BSTR;

   function To_BSTR( From_C : Interfaces.C.WChar_Array ) return Win32.OleAuto.BSTR;
   function To_BSTR( From_C : Interfaces.C.Char_Array ) return Win32.OleAuto.BSTR;

   -- These conversion functions do not destroy the original BSTR

   function To_Ada( From_BSTR : Win32.OleAuto.BSTR ) return Wide_String;
   function To_Ada( From_BSTR : Win32.OleAuto.BSTR ) return String;

   function To_C( From_BSTR : Win32.OleAuto.BSTR ) return Interfaces.C.WChar_Array;
   function To_C( From_BSTR : Win32.OleAuto.BSTR ) return Interfaces.C.Char_Array;

   -- This conversion can free BSTRs created with this packages conversion
   -- functions and those created with the Win32 API function SysAllocString
   
   procedure Free( This : Win32.OleAuto.BSTR );
   
   BSTR_Error : exception;
   
end BSTR;

with Win32.Oleauto; use Win32.Oleauto;

with Interfaces.C; use Interfaces.C;
with Interfaces.C.Pointers;

with Ada.Exceptions;
with Ada.Characters.Handling;
with Ada.Unchecked_Conversion;

with System;

package body BSTR is

-------------------------------------------------------------------------------
-- Private
-------------------------------------------------------------------------------
   type PWChar_t is access all Interfaces.C.WChar_t;

   function To_PCWSTR is
      new Ada.Unchecked_Conversion (System.Address, Win32.PCWSTR);
   function To_PWChar_t is
      new Ada.Unchecked_Conversion (System.Address, PWChar_t);


   package WChar_Array_Pointer is new Interfaces.C.Pointers
         (index              => Interfaces.C.Size_t,
          element            => Interfaces.C.WChar_t,
          element_array      => Interfaces.C.WChar_array,
          default_terminator => Interfaces.C.Wide_Nul);

-------------------------------------------------------------------------------
-- Public
-------------------------------------------------------------------------------

   -- Create BSTR conversions
   
   function To_BSTR (From_Ada : Wide_String) return Win32.OleAuto.BSTR is
   begin
      return To_BSTR(
                Interfaces.C.To_C(From_Ada) );
   end To_BSTR;

   function To_BSTR (From_Ada : String) return Win32.OleAuto.BSTR is
   begin
      return To_BSTR (
                Interfaces.C.To_C(
                   Ada.Characters.Handling.To_Wide_String(From_Ada) ) );
   end To_BSTR;

   function To_BSTR (From_C : Interfaces.C.WChar_Array)
      return Win32.OleAuto.BSTR
   is
      New_BSTR : Win32.OleAuto.BSTR;
   begin
      New_BSTR := SysAllocString( To_PCWSTR( From_C'Address ) );

      if New_BSTR = null then
         Ada.Exceptions.Raise_Exception(BSTR_Error'Identity,
            "BSTR - Unable to create BSTR");
      end if;
      
      return New_BSTR;
   end To_BSTR;

   function To_BSTR (From_C : Interfaces.C.Char_Array)
      return Win32.OleAuto.BSTR
   is
   begin
      return To_BSTR (
                Interfaces.C.To_C(
                   Ada.Characters.Handling.To_Wide_String(
                      Interfaces.C.To_Ada(From_C) ) ) );
   end To_BSTR;

   -- Convert to Ada and C strings

   function To_Ada (From_BSTR : Win32.OleAuto.BSTR) return Wide_String is
   begin
      return Interfaces.C.To_Ada(
                To_C(From_BSTR) );
   end To_Ada;

   function To_Ada (From_BSTR : Win32.OleAuto.BSTR) return String is
   begin
      return Ada.Characters.Handling.To_String(
                To_Ada (From_BSTR) );
   end To_Ada;

   function To_C (From_BSTR : Win32.OleAuto.BSTR)
      return Interfaces.C.WChar_Array
   is
   begin
      return WChar_Array_Pointer.value (WChar_Array_Pointer.pointer (To_PWChar_t(From_BSTR.all'Address)));
   end To_C;

   function To_C (From_BSTR : Win32.OleAuto.BSTR)
      return Interfaces.C.Char_Array
   is
   begin
      return Interfaces.C.To_C(
                Ada.Characters.Handling.To_String(
                   Interfaces.C.To_Ada(
                      To_C(From_BSTR) ) ) );
   end To_C;

   -- Destroy BSTRs
   
   procedure Free (This : Win32.OleAuto.BSTR) is
   begin
      SysFreeString(This);
   end Free;

end BSTR;