-- Programmed by Jedidiah Barber -- Released into the public domain pragma Ada_2012; with Ada.Containers, Ada.Strings.Fixed, Ada.Strings.Maps, Interfaces.C.Strings, System.Storage_Elements; use type Ada.Containers.Count_Type, Interfaces.C.int, Interfaces.C.Strings.chars_ptr, System.Address; package body Libao is package Str renames Ada.Strings; package SFix renames Ada.Strings.Fixed; package SMap renames Ada.Strings.Maps; ------------------------ -- Constants From C -- ------------------------ type_live : constant Interfaces.C.int; pragma Import (C, type_live, "type_live"); type_file : constant Interfaces.C.int; pragma Import (C, type_file, "type_file"); sample_little_endian : constant Interfaces.C.int; pragma Import (C, sample_little_endian, "sample_little_endian"); sample_big_endian : constant Interfaces.C.int; pragma Import (C, sample_big_endian, "sample_big_endian"); sample_native_endian : constant Interfaces.C.int; pragma Import (C, sample_native_endian, "sample_native_endian"); error_no_driver : constant Interfaces.C.int; pragma Import (C, error_no_driver, "error_no_driver"); error_not_file : constant Interfaces.C.int; pragma Import (C, error_not_file, "error_not_file"); error_not_live : constant Interfaces.C.int; pragma Import (C, error_not_live, "error_not_live"); error_bad_option : constant Interfaces.C.int; pragma Import (C, error_bad_option, "error_bad_option"); error_open_device : constant Interfaces.C.int; pragma Import (C, error_open_device, "error_open_device"); error_open_file : constant Interfaces.C.int; pragma Import (C, error_open_file, "error_open_file"); error_file_exists : constant Interfaces.C.int; pragma Import (C, error_file_exists, "error_file_exists"); error_bad_format : constant Interfaces.C.int; pragma Import (C, error_bad_format, "error_bad_format"); error_fail : constant Interfaces.C.int; pragma Import (C, error_fail, "error_fail"); ------------------------ -- Functions From C -- ------------------------ procedure ao_initialize; pragma Import (C, ao_initialize, "ao_initialize"); procedure ao_shutdown; pragma Import (C, ao_shutdown, "ao_shutdown"); function ao_append_option (Options : in out Storage.Integer_Address; Key : in Interfaces.C.char_array; Value : in Interfaces.C.char_array) return Interfaces.C.int; pragma Import (C, ao_append_option, "ao_append_option"); function ao_append_global_option (Key : in Interfaces.C.char_array; Value : in Interfaces.C.char_array) return Interfaces.C.int; pragma Import (C, ao_append_global_option, "ao_append_global_option"); procedure ao_free_options (Options : in Storage.Integer_Address); pragma Import (C, ao_free_options, "ao_free_options"); function ao_open_live (Driver_ID : in Interfaces.C.int; Format : in Storage.Integer_Address; Options : in Storage.Integer_Address) return Storage.Integer_Address; pragma Import (C, ao_open_live, "ao_open_live"); function ao_open_file (Driver_ID : in Interfaces.C.int; Filename : in Interfaces.C.char_array; Overwrite : in Interfaces.C.int; Format : in Storage.Integer_Address; Options : in Storage.Integer_Address) return Storage.Integer_Address; pragma Import (C, ao_open_file, "ao_open_file"); function ao_play (Output_Device : in Storage.Integer_Address; Samples : in Storage.Integer_Address; Num_Bytes : in Interfaces.Unsigned_32) return Interfaces.C.int; pragma Import (C, ao_play, "ao_play"); function ao_close (Output_Device : in Storage.Integer_Address) return Interfaces.C.int; pragma Import (C, ao_close, "ao_close"); function ao_driver_id (Short_Name : in Interfaces.C.char_array) return Interfaces.C.int; pragma Import (C, ao_driver_id, "ao_driver_id"); function ao_default_driver_id return Interfaces.C.int; pragma Import (C, ao_default_driver_id, "ao_default_driver_id"); function ao_driver_info (Ident : in Interfaces.C.int) return Storage.Integer_Address; pragma Import (C, ao_driver_info, "ao_driver_info"); function ao_driver_info_list (Count : out Interfaces.C.int) return Storage.Integer_Address; pragma Import (C, ao_driver_info_list, "ao_driver_info_list"); function ao_file_extension (Ident : in Interfaces.C.int) return Interfaces.C.Strings.chars_ptr; pragma Import (C, ao_file_extension, "ao_file_extension"); function ao_is_big_endian return Interfaces.C.int; pragma Import (C, ao_is_big_endian, "ao_is_big_endian"); function info_item_get (Infos : in Storage.Integer_Address; Index : in Interfaces.C.int) return Storage.Integer_Address; pragma Import (C, info_item_get, "info_item_get"); pragma Inline (info_item_get); function info_kind_get (Item : in Storage.Integer_Address) return Interfaces.C.int; pragma Import (C, info_kind_get, "info_kind_get"); pragma Inline (info_kind_get); function info_name_get (Item : in Storage.Integer_Address) return Interfaces.C.Strings.chars_ptr; pragma Import (C, info_name_get, "info_name_get"); pragma Inline (info_name_get); function info_short_name_get (Item : in Storage.Integer_Address) return Interfaces.C.Strings.chars_ptr; pragma Import (C, info_short_name_get, "info_short_name_get"); pragma Inline (info_short_name_get); function info_preferred_byte_format_get (Item : in Storage.Integer_Address) return Interfaces.C.int; pragma Import (C, info_preferred_byte_format_get, "info_preferred_byte_format_get"); pragma Inline (info_preferred_byte_format_get); function info_priority_get (Item : in Storage.Integer_Address) return Interfaces.C.int; pragma Import (C, info_priority_get, "info_priority_get"); pragma Inline (info_priority_get); function info_comment_get (Item : in Storage.Integer_Address) return Interfaces.C.Strings.chars_ptr; pragma Import (C, info_comment_get, "info_comment_get"); pragma Inline (info_comment_get); function info_option_count_get (Item : in Storage.Integer_Address) return Interfaces.C.int; pragma Import (C, info_option_count_get, "info_option_count_get"); pragma Inline (info_option_count_get); function info_option_key_get (Item : in Storage.Integer_Address; Index : in Interfaces.C.int) return Interfaces.C.Strings.chars_ptr; pragma Import (C, info_option_key_get, "info_option_key_get"); pragma Inline (info_option_key_get); function get_errno return Interfaces.C.int; pragma Import (C, get_errno, "get_errno"); pragma Inline (get_errno); function option_key (Item : in Storage.Integer_Address) return Interfaces.C.Strings.chars_ptr; pragma Import (C, option_key, "option_key"); pragma Inline (option_key); function option_value (Item : in Storage.Integer_Address) return Interfaces.C.Strings.chars_ptr; pragma Import (C, option_value, "option_value"); pragma Inline (option_value); function option_next (Item : in Storage.Integer_Address) return Storage.Integer_Address; pragma Import (C, option_next, "option_next"); pragma Inline (option_next); ------------------------ -- Internal Utility -- ------------------------ procedure Do_Append (Ptr_List : in out Address_Vectors.Vector; Key : in Interfaces.C.char_array; Value : in Interfaces.C.char_array) is Result : Interfaces.C.int; Head : Storage.Integer_Address := Head_Pointer (Ptr_List); begin Result := ao_append_option (Head, Key, Value); if Result = 0 then raise Storage_Error; elsif Result /= 1 then raise Program_Error; else if Ptr_List.Length = 0 then Ptr_List.Append (Head); else Ptr_List.Append (option_next (Ptr_List.Last_Element)); end if; end if; end Do_Append; procedure Do_Close (Ptr : in Storage.Integer_Address) is Result : Interfaces.C.int := ao_close (Ptr); begin if Result = 0 then raise Close_Device_Error; elsif Result /= 1 then raise Program_Error; end if; end Do_Close; function Head_Pointer (This : in Address_Vectors.Vector) return Storage.Integer_Address is begin if This.Length = 0 then return Null_Pointer; else return This.First_Element; end if; end Head_Pointer; ----------------------------------- -- Controlled Type Subprograms -- ----------------------------------- procedure Adjust (This : in out Option_List) is Old : Storage.Integer_Address := Head_Pointer (This.Ptr_List); begin This.Ptr_List := Address_Vectors.Empty_Vector; while Old /= Null_Pointer loop Do_Append (This.Ptr_List, Interfaces.C.Strings.Value (option_key (Old)), Interfaces.C.Strings.Value (option_value (Old))); Old := option_next (Old); end loop; end Adjust; procedure Finalize (This : in out Option_List) is begin ao_free_options (Head_Pointer (This.Ptr_List)); end Finalize; procedure Adjust (This : in out Sample_Format) is begin This.C_Struct.Matrix := Interfaces.C.Strings.New_String (Interfaces.C.Strings.Value (This.C_Struct.Matrix)); end Adjust; procedure Finalize (This : in out Sample_Format) is begin Interfaces.C.Strings.Free (This.C_Struct.Matrix); end Finalize; procedure Finalize (This : in out Final_Controller) is begin for Addy of Device_List loop Do_Close (Addy); end loop; ao_shutdown; end Finalize; --------------------------------- -- Data Types and Structures -- --------------------------------- function Kind (Attributes : in Info) return Output_Kind is Value : Interfaces.C.int := info_kind_get (Attributes.Ptr); begin if Value = type_live then return Live_Output; elsif Value = type_file then return File_Output; else raise Program_Error; end if; end Kind; function Name (Attributes : in Info) return String is begin return Interfaces.C.Strings.Value (info_name_get (Attributes.Ptr)); end Name; function Short_Name (Attributes : in Info) return String is begin return Interfaces.C.Strings.Value (info_short_name_get (Attributes.Ptr)); end Short_Name; function Preferred_Byte_Format (Attributes : in Info) return Endianness is Value : Interfaces.C.int := info_preferred_byte_format_get (Attributes.Ptr); begin if Value = sample_little_endian then return Little_Endian; elsif Value = sample_big_endian then return Big_Endian; elsif Value = sample_native_endian then return Machine_Native; else raise Program_Error; -- libao would be doing weird shit to get here end if; end Preferred_Byte_Format; function Priority_Level (Attributes : in Info) return Natural is begin return Natural (info_priority_get (Attributes.Ptr)); end Priority_Level; function Comment (Attributes : in Info) return String is begin return Interfaces.C.Strings.Value (info_comment_get (Attributes.Ptr)); end Comment; function Option_Count (Attributes : in Info) return Natural is begin return Natural (info_option_count_get (Attributes.Ptr)); end Option_Count; function Option_Key (Attributes : in Info; Index : in Positive) return String is begin return Interfaces.C.Strings.Value (info_option_key_get (Attributes.Ptr, Interfaces.C.int (Index) - 1)); end Option_Key; function Length (Options : in Option_List) return Natural is begin return Natural (Options.Ptr_List.Length); end Length; function Key (Options : in Option_List; Index : in Positive) return String is begin return Interfaces.C.Strings.Value (option_key (Options.Ptr_List.Element (Index))); end Key; function Value (Options : in Option_List; Index : in Positive) return String is begin return Interfaces.C.Strings.Value (option_value (Options.Ptr_List.Element (Index))); end Value; function Image_Length (Channel : in Channel_Mnemonic) return Positive is begin case Channel is when L | R | C | M | X => return 1; when CL | CR | BL | BR | BC | SL | SR | A1 | A2 | A3 | A4 => return 2; when LFE => return 3; end case; end Image_Length; function Image_Length (Channel_Matrix : in Mnemonic_Array) return Natural is -- Start by counting all the commas Result : Integer := Channel_Matrix'Length - 1; begin if Channel_Matrix'Length = 0 then return 0; end if; for Channel of Channel_Matrix loop Result := Result + Image_Length (Channel); end loop; return Result; end Image_Length; function Image (Channel_Matrix : in Mnemonic_Array) return String is Result : String (1 .. Image_Length (Channel_Matrix)); Position : Integer := 1; Token_End : Positive; begin for Index in Integer range Channel_Matrix'First .. Channel_Matrix'Last - 1 loop Token_End := Position + Image_Length (Channel_Matrix (Index)); Result (Position .. Token_End) := Channel_Matrix (Index)'Image & ","; Position := Token_End + 1; end loop; Result (Position .. Result'Last) := Channel_Matrix (Channel_Matrix'Last)'Image; return Result; end Image; function Create (Bits, Rate, Channels : in Positive; Byte_Format : in Endianness; Channel_Matrix : in Mnemonic_Array) return Sample_Format is begin return This : Sample_Format := (Ada.Finalization.Controlled with C_Struct => (Bits => Interfaces.C.int (Bits), Rate => Interfaces.C.int (Rate), Channels => Interfaces.C.int (Channels), Byte_Format => (case Byte_Format is when Little_Endian => sample_little_endian, when Big_Endian => sample_big_endian, when Machine_Native => sample_native_endian), Matrix => Interfaces.C.Strings.New_String (Image (Channel_Matrix)))); end Create; function Bits (Format : in Sample_Format) return Positive is begin return Positive (Format.C_Struct.Bits); end Bits; function Rate (Format : in Sample_Format) return Positive is begin return Positive (Format.C_Struct.Rate); end Rate; function Channels (Format : in Sample_Format) return Positive is begin return Positive (Format.C_Struct.Channels); end Channels; function Byte_Format (Format : in Sample_Format) return Endianness is begin if Format.C_Struct.Byte_Format = sample_little_endian then return Little_Endian; elsif Format.C_Struct.Byte_Format = sample_big_endian then return Big_Endian; elsif Format.C_Struct.Byte_Format = sample_native_endian then return Machine_Native; else raise Constraint_Error; end if; end Byte_Format; function Channel_Matrix (Format : in Sample_Format) return Mnemonic_Array is Input : String := Interfaces.C.Strings.Value (Format.C_Struct.Matrix); Result : Mnemonic_Array (1 .. SFix.Count (Input, SMap.To_Set (',')) + 1); First : Positive := 1; Last : Natural; Place : Positive := 1; begin if Input'Length = 0 then return Empty : Mnemonic_Array (1 .. 0); end if; while First <= Input'Last loop SFix.Find_Token (Source => Input, Set => SMap.To_Set (','), From => First, Test => Str.Outside, First => First, Last => Last); exit when Last = 0; Result (Place) := Channel_Mnemonic'Value (Input (First .. Last)); Place := Place + 1; First := Last + 1; end loop; return Result; end Channel_Matrix; -------------------------------------- -- Device Setup/Playback/Teardown -- -------------------------------------- procedure Append (This : in out Option_List; Key : in String; Value : in String) is begin Do_Append (This.Ptr_List, Interfaces.C.To_C (Key), Interfaces.C.To_C (Value)); end Append; procedure Append_Global_Option (Key : in String; Value : in String) is Result : Interfaces.C.int; begin Result := ao_append_global_option (Interfaces.C.To_C (Key), Interfaces.C.To_C (Value)); if Result = 0 then raise Storage_Error; elsif Result /= 1 then raise Program_Error; end if; end Append_Global_Option; procedure Open_Live (Output : in out Device; Driver_ID : in Driver_ID_Number; Format : in Sample_Format'Class; Options : in Option_List'Class) is Result : Storage.Integer_Address := ao_open_live (Driver_ID => Interfaces.C.int (Driver_ID), Format => Storage.To_Integer (Format.C_Struct'Address), Options => Head_Pointer (Options.Ptr_List)); My_Errno : Interfaces.C.int; begin if Result = Null_Pointer then My_Errno := get_errno; if My_Errno = error_no_driver then raise No_Driver_Error; elsif My_Errno = error_not_live then raise Not_Live_Error; elsif My_Errno = error_bad_option then raise Bad_Option_Error; elsif My_Errno = error_open_device then raise Open_Device_Error; elsif My_Errno = error_bad_format then raise Bad_Format_Error; elsif My_Errno = error_fail then raise General_Failure; else raise Program_Error; end if; else Output.Close; Device_List.Append (Result); Output.Ptr := Result; end if; end Open_Live; procedure Open_File (Output : in out Device; Driver_ID : in Driver_ID_Number; Filename : in String; Format : in Sample_Format'Class; Options : in Option_List'Class; Overwrite : in Boolean := False) is Result : Storage.Integer_Address := ao_open_file (Driver_ID => Interfaces.C.int (Driver_ID), Filename => Interfaces.C.To_C (Filename), Overwrite => Boolean'Pos (Overwrite), Format => Storage.To_Integer (Format.C_Struct'Address), Options => Head_Pointer (Options.Ptr_List)); My_Errno : Interfaces.C.int; begin if Result = Null_Pointer then My_Errno := get_errno; if My_Errno = error_no_driver then raise No_Driver_Error; elsif My_Errno = error_not_file then raise Not_File_Error; elsif My_Errno = error_bad_option then raise Bad_Option_Error; elsif My_Errno = error_open_file then raise Open_File_Error; elsif My_Errno = error_file_exists then raise File_Exists_Error; elsif My_Errno = error_bad_format then raise Bad_Format_Error; elsif My_Errno = error_fail then raise General_Failure; else raise Program_Error; end if; else Output.Close; Device_List.Append (Result); Output.Ptr := Result; end if; end Open_File; procedure Play (Output : in Device; Samples : in Data_Buffer) is Result : Interfaces.C.int := ao_play (Output_Device => Output.Ptr, Samples => Storage.To_Integer (Samples'Address), Num_Bytes => Interfaces.Unsigned_32 (Samples'Length)); begin if Result = 0 then raise General_Failure; end if; end Play; procedure Close (Output : in out Device) is Found : Boolean := False; begin for Index in reverse Integer range Device_List.First_Index .. Device_List.Last_Index loop if Device_List.Element (Index) = Output.Ptr then Device_List.Delete (Index); Found := True; end if; end loop; if Found then Do_Close (Output.Ptr); end if; Output.Ptr := Null_Pointer; end Close; -------------------------- -- Driver Information -- -------------------------- function Driver_ID (Short_Name : in String) return Driver_ID_Number is Result : Interfaces.C.int; begin Result := ao_driver_id (Interfaces.C.To_C (Short_Name)); if Result = -1 then raise No_Driver_Error; elsif Result < 0 then raise Program_Error; end if; return Driver_ID_Number (Result); end Driver_ID; function Default_Driver_ID return Driver_ID_Number is Result : Interfaces.C.int; begin Result := ao_default_driver_id; if Result = -1 then raise No_Device_Error; elsif Result < 0 then raise Program_Error; end if; return Driver_ID_Number (Result); end Default_Driver_ID; function Driver_Info (Ident : in Driver_ID_Number) return Info is Result : Storage.Integer_Address; begin Result := ao_driver_info (Interfaces.C.int (Ident)); if Result = Null_Pointer then raise No_Driver_Error; else return (Ptr => Result); end if; end Driver_Info; function Driver_Info_List return Info_Array is Count : Interfaces.C.int; Carr : Storage.Integer_Address; begin Carr := ao_driver_info_list (Count); return Actual : Info_Array (1 .. Positive (Count)) do for N in Integer range Actual'First .. Actual'Last loop Actual (N) := (Ptr => info_item_get (Carr, Interfaces.C.int (N - 1))); end loop; end return; end Driver_Info_List; function File_Extension (Ident : in Driver_ID_Number) return String is Result : Interfaces.C.Strings.chars_ptr := ao_file_extension (Interfaces.C.int (Ident)); begin if Result = Interfaces.C.Strings.Null_Ptr then return ""; else return Interfaces.C.Strings.Value (Result); end if; end File_Extension; --------------------- -- Miscellaneous -- --------------------- function Is_Big_Endian return Boolean is begin case ao_is_big_endian is when 1 => return True; when 0 => return False; when others => raise Program_Error; end case; end Is_Big_Endian; begin ao_initialize; end Libao;