--  music123 by
--  David Starner <dvdeug@debian.org>
--  Xavier Grave <xavier.grave@csnsm.in2p3.fr>
--  Nicolas Boulenguez <nicolas@debian.org>

with Ada.Characters.Latin_1;
with Ada.Command_Line;
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Containers.Indefinite_Vectors;
with Ada.Directories;
use all type Ada.Directories.Directory_Entry_Type;
use all type Ada.Directories.File_Kind;
use all type Ada.Directories.Search_Type;
with Ada.Environment_Variables;
with Ada.Numerics.Float_Random;
use all type Ada.Numerics.Float_Random.Generator;
with Ada.Strings.Fixed;
with Ada.Strings.Hash;
with Ada.Strings.Maps;
use all type Ada.Strings.Maps.Character_Set;
with Ada.Strings.Maps.Constants;        use Ada.Strings.Maps.Constants;
with Ada.Strings.Unbounded;
use all type Ada.Strings.Unbounded.Unbounded_String;
with Ada.Text_IO;
with Interfaces.C.Strings;

procedure Music123 is

   Version_Number       : constant String := "16.5";
   System_Configuration : constant String := "/etc/music123rc";
   User_Configuration   : constant String := ".music123rc";
   --  User_Configuration is relative to the HOME directory.

   ----------------------------------------------------------------------
   --  Interface with C.

   C_Error : exception;
   --  Used to report errors at the C level.

   LC_ALL : constant := 6;
   --  Quite arbitrary, but has been working for years, and gcc is not
   --  able to generate such values yet.

   --  From locale.h:
   procedure Setlocale (Category : Interfaces.C.int;
                        Locale   : String);

   --  From libintl.h:
   procedure Textdomain (Domainname : String);
   procedure Bindtextdomain (Domainname : String;
                             Dirname    : String);
   function "+" (Msgid : String) return String; --  gettext

   --  From stdlib.h:
   procedure System (Command : String);

   ----------------------------------------------------------------------
   --  Error reporting

   Error : exception;                  --  Report and set exit status.
   procedure Warn (Message : String);  --  Report but continue.

   ----------------------------------------------------------------------
   --  Random numbers

   Generator : Ada.Numerics.Float_Random.Generator;

   function Random (Maximum : Positive) return Positive
     with Post => Random'Result in 1 .. Maximum;

   ----------------------------------------------------------------------
   --  Types

   type An_Option_List is record
      Catch_Q_In_Stdin      : Boolean     := False;
      Delay_Length          : Duration    := 0.5;
      Eternal_Random        : Boolean     := False;
      Ignore_Extension_Case : Boolean     := False;
      List_Files_Only       : Boolean     := False;
      Quiet                 : Boolean     := False;
      Random                : Boolean     := False;
      Recurse               : Boolean     := False;
      Repeat                : Boolean     := False;
   end record;

   package Tool_Maps is new Ada.Containers.Indefinite_Hashed_Maps
     (Key_Type        => String,
      Element_Type    => String,
      Hash            => Ada.Strings.Hash,
      Equivalent_Keys => "=");
   --  For each known extension, store to the first matching tool in
   --  the configuration file.  The element contains the name of the
   --  program followed by the options.

   package String_Vectors is new Ada.Containers.Indefinite_Vectors
     (Index_Type   => Positive,
      Element_Type => String);
   package String_Sorting is new String_Vectors.Generic_Sorting ("<");

   procedure Parse_Command_Line (Paths   : in out String_Vectors.Vector;
                                 Options : in out An_Option_List;
                                 Done    :    out Boolean);

   --  The options are transmitted so that the extensions are
   --  translated to lower case if necessary.
   procedure Parse_Configuration (Tools   : in out Tool_Maps.Map;
                                  Options :        An_Option_List);

   --  Ignore directories (unless Options.Recurse), special files, or
   --  files without matching command in Tools.
   --  For selected paths, construct a shell script playing the song
   --  and append it to Commands.
   --  If Options.List_Files_Only, then Commands are not modified but
   --  selected paths are printed instead.
   procedure Add_Command (Commands : in out String_Vectors.Vector;
                          Path     :        String;
                          Tools    :        Tool_Maps.Map;
                          Options  :        An_Option_List);

   procedure Randomize (Commands : in out String_Vectors.Vector);

   procedure Play_Songs (Commands : String_Vectors.Vector;
                         Options  : An_Option_List);

   ----------------------------------------------------------------------
   --  Implementations

   function "+" (Msgid : String) return String is
      use Interfaces.C, Interfaces.C.Strings;
      function F (A1 : char_array := To_C (Msgid)) return chars_ptr
        with Import, Convention => C, External_Name => "gettext";
      Ret : constant chars_ptr := F;
   begin
      if Ret = Null_Ptr then
         raise C_Error with "gettext failed";
      end if;
      return Value (Ret);
   end "+";

   procedure Bindtextdomain (Domainname : String;
                             Dirname    : String) is
      use Interfaces.C, Interfaces.C.Strings;
      function F (A1 : char_array := To_C (Domainname);
                  A2 : char_array := To_C (Dirname)) return chars_ptr
        with Import, Convention => C, External_Name => "bindtextdomain";
   begin
      if F = Null_Ptr then
         raise C_Error with "bindtextdomain failed";
      end if;
   end Bindtextdomain;

   procedure Add_Command (Commands : in out String_Vectors.Vector;
                          Path     :        String;
                          Tools    :        Tool_Maps.Map;
                          Options  :        An_Option_List) is

      procedure Process_Directory;
      procedure Process_Ordinary_File;

      procedure Process_Directory is
         Search          : Ada.Directories.Search_Type;
         Directory_Entry : Ada.Directories.Directory_Entry_Type;
         More_Paths      : String_Vectors.Vector;
      begin
         begin
            Start_Search (Search, Directory => Path, Pattern => "");
         exception
            when Ada.Directories.Name_Error =>
               Warn (+"Empty directory: " & Path);
               return;
            when Ada.Directories.Use_Error =>
               Warn (+"Not allowed to enter directory: " & Path);
               return;
         end;
         while More_Entries (Search) loop
            Get_Next_Entry (Search, Directory_Entry);
            --  Ignore . .. and more generally hidden files.
            declare
               S : constant String := Simple_Name (Directory_Entry);
            begin
               if S /= "" and then S (S'First) /= '.' then
                  More_Paths.Append (Full_Name (Directory_Entry));
               end if;
            end;
         end loop;
         --  Make the order independant from the underlying file system.
         String_Sorting.Sort (String_Vectors.Vector (More_Paths));
         for New_Path of More_Paths loop
            Add_Command (Commands, New_Path, Tools, Options);
         end loop;
      end Process_Directory;

      procedure Process_Ordinary_File is
         Ext      : constant String := Ada.Directories.Extension (Path);
         Key      : constant String
           := (if Options.Ignore_Extension_Case
                 then Ada.Strings.Fixed.Translate (Ext, Lower_Case_Map)
                 else Ext);
         Position : constant Tool_Maps.Cursor := Tools.Find (Key);
         Buffer   : Ada.Strings.Unbounded.Unbounded_String;
      begin
         if not Tool_Maps.Has_Element (Position) then
            Warn (+"Unknown extension: " & Path);
         elsif Options.List_Files_Only then
            Ada.Text_IO.Put_Line (Path);
         else
            Set_Unbounded_String (Buffer, Tools (Position));
            Append (Buffer, " '");
            for Char of Path loop
               if Char = ''' then
                  Append (Buffer, "'\''");
               else
                  Append (Buffer, Char);
               end if;
            end loop;
            Append (Buffer, ''');
            if Options.Quiet then
               Append (Buffer, " > /dev/null");
            end if;
            if Options.Catch_Q_In_Stdin then
               Append (Buffer, " < /dev/null");
            end if;
            Commands.Append (To_String (Buffer));
         end if;
      end Process_Ordinary_File;

   begin
      if Ada.Directories.Exists (Path) then
         case Kind (Path) is
            when Special_File =>
               Warn (+"Not an ordinary file: " & Path);
            when Directory =>
               if Options.Recurse then
                  Process_Directory;
               else
                  Warn (+"Directory: " & Path);
               end if;
            when Ordinary_File =>
               Process_Ordinary_File;
         end case;
      else
         Warn (+"No such file: " & Path);
      end if;
   end Add_Command;

   procedure Parse_Command_Line (Paths   : in out String_Vectors.Vector;
                                 Options : in out An_Option_List;
                                 Done    :    out Boolean) is

      procedure Display_Help;
      procedure Display_Version;
      procedure Read_Playlist (Path : String);
      procedure Read_Playlist_Line (Line : String);
      procedure Set_Delay (Value : String);

      procedure Display_Help is
         use Ada.Text_IO;
      begin
         Put_Line
           (+"Usage: music123 [-DhiLlqrvZz] [-d ARG] [-@ ARG] [--] files ...");
         Put_Line (+"-z     Shuffle list before playing");
         Put_Line (+"-l     Loop when reaching end of playlist");
         Put_Line (+"-Z     Play randomly. Never stop");
         New_Line;
         Put_Line (+"-r     Recurse over directories");
         Put_Line (+"-@ ARG Add lines of ARG to files");
         Put_Line (+"--     Following arguments are files, not options");
         Put_Line (+"-i     Ignore case of file extensions (.OGG = .ogg)");
         Put_Line (+"-L     List files and exit. No music");
         New_Line;
         Put_Line (+"-q     Run quietly");
         Put_Line (+"-d ARG Delay ARG seconds between songs (default: 0.5)");
         Put_Line (+"-D     Shortcut for -d 0");
         Put_Line (+"-T     Catch q key to quit after current song");
         New_Line;
         Put_Line (+"-v     Print version information");
         Put_Line (+"-h     Print this help");
         New_Line;
         Put_Line (+"See the manpage for more options.");
      end Display_Help;

      procedure Display_Version is
         --  Translate the format, then replace the major version.
         Format : constant String   := +"music123 version %d by David Starner";
         I      : constant Positive := Ada.Strings.Fixed.Index (Format, "%d");
      begin
         Ada.Text_IO.Put_Line
           (Ada.Strings.Fixed.Replace_Slice (Source => Format,
                                             Low    => I,
                                             High   => I + 1,
                                             By     => Version_Number));
      end Display_Version;

      procedure Read_Playlist (Path : String) is
         use Ada.Text_IO;
         Playlist : Ada.Text_IO.File_Type;
      begin
         begin
            Open (Playlist, In_File, Path);
         exception
            when others =>
               raise Error with +"Playlist file not found.";
         end;
         while not End_Of_File (Playlist) loop
            Read_Playlist_Line (Get_Line (Playlist));
         end loop;
         Close (Playlist);
      exception
         when others =>
            if Is_Open (Playlist) then
               Close (Playlist);
            end if;
            raise Error with +"unable to parse playlist: " & Path;
      end Read_Playlist;

      procedure Read_Playlist_Line (Line : String) is
         Path : constant String
           := Ada.Strings.Fixed.Trim (Line, Ada.Strings.Both);
      begin
         if Path /= "" and then Path (Path'First) /= '#' then
            Paths.Append (Path);
         end if;
      end Read_Playlist_Line;

      procedure Set_Delay (Value : String) is
      begin
         Options.Delay_Length := Duration'Value (Value);
      exception
         when Constraint_Error =>
            raise Error with +"Bad argument for -d.";
      end Set_Delay;

      use Ada.Command_Line;
      Arg_Num        : Positive := 1;
      Ignore_Options : Boolean  := False;
   begin
      while Arg_Num <= Argument_Count loop
         declare
            Arg : String renames Argument (Arg_Num);
            --  The reference manual guarantees that Arg'First = 1.
         begin
            if Ignore_Options or else Arg'Last < 2 or else Arg (1) /= '-' then
               Paths.Append (Arg);
            else
               Letters : for I in 2 .. Arg'Last loop
                  case Arg (I) is
                     when '-' =>
                        if Arg'Last /= 2 then
                           raise Error with +"Unknown option: -";
                        end if;
                        Ignore_Options := True;
                     when '@' =>
                        if I < Arg'Last then
                           Read_Playlist (Arg (I + 1 .. Arg'Last));
                           exit Letters;
                        elsif Arg_Num < Argument_Count then
                           Arg_Num := Arg_Num + 1;
                           Read_Playlist (Argument (Arg_Num));
                        else
                           raise Error with +"Missing argument for: -" & "@";
                        end if;
                     when 'D' =>
                        Options.Delay_Length  := 0.0;
                     when 'd' =>
                        if I < Arg'Last then
                           Set_Delay (Arg (I + 1 .. Arg'Last));
                           exit Letters;
                        elsif Arg_Num < Argument_Count then
                           Arg_Num := Arg_Num + 1;
                           Set_Delay (Argument (Arg_Num));
                        else
                           raise Error with +"Missing argument for -" & "d";
                        end if;
                     when 'h' =>
                        Display_Version;
                        Display_Help;
                        Done := True;
                        return;
                     when 'i' =>
                        Options.Ignore_Extension_Case := True;
                     when 'L' =>
                        Options.List_Files_Only := True;
                     when 'l' =>
                        Options.Repeat := True;
                     when 'q' =>
                        Options.Quiet := True;
                     when 'r' =>
                        Options.Recurse := True;
                     when 'T' =>
                        Options.Catch_Q_In_Stdin := True;
                     when 'v' =>
                        Display_Version;
                        Done := True;
                        return;
                     when 'Z' =>
                        Options.Eternal_Random := True;
                     when 'z' =>
                        Options.Random := True;
                     when others =>
                        raise Error with +"Unknown option: " &  Arg (I);
                  end case;
               end loop Letters;
            end if;
         end;
         Arg_Num := Arg_Num + 1;
      end loop;
      Done := False;
   end Parse_Command_Line;

   procedure Parse_Configuration (Tools   : in out Tool_Maps.Map;
                                  Options :        An_Option_List) is

      procedure Parse_File (Path : String);
      procedure Parse_Line (Line : String);

      procedure Parse_File (Path : String) is
         use Ada.Text_IO;
         File : File_Type;
      begin
         Open (File, In_File, Path);
         while not End_Of_File (File) loop
            Parse_Line (Get_Line (File));
         end loop;
         Close (File);
      exception
         when others =>
            if Is_Open (File) then
               Close (File);
            end if;
            Warn (+"error in configuration file: " & Path);
            raise;
      end Parse_File;

      procedure Parse_Line (Line : String) is
         HT      : Character renames Ada.Characters.Latin_1.HT;
         Outside : Ada.Strings.Membership renames Ada.Strings.Outside;
         Whitespace : constant Ada.Strings.Maps.Character_Set
           := To_Set (Sequence => (' ', HT));
         T_F, T_L, P_F, P_L, E_F, E_L, O_F, O_L : Integer;
         use Ada.Strings.Fixed;
      begin
         Find_Token (Line, Whitespace, Outside, T_F, T_L);
         if T_L = 0                        --  Line only contains blanks.
           or else Line (T_F) = '#'        --  Comment.
         then
            return;
         elsif Line (T_F .. T_L) /= "tool" --  Unexpected keyword.
           or else T_L = Line'Last         --  Only "tool"
         then
            Warn (+"suspicious configuration line: " & Line);
            return;
         end if;

         Find_Token (Line, Whitespace, T_L + 1, Outside, P_F, P_L);
         if P_L = 0 or else P_L = Line'Last then
            Warn (+"suspicious configuration line::" & Line);
            return;
         end if;

         Find_Token (Line, Whitespace, P_L + 1, Outside, E_F, E_L);
         if E_L = 0 or else E_L = Line'Last then
            Warn (+"suspicious configuration line::" & Line);
            return;
         end if;

         O_F := Index (Line, Whitespace, E_L + 1, Outside);
         if O_F = 0 or else O_F = Line'Last or else Line (O_F) /= '"' then
            Warn (+"suspicious configuration line::" & Line);
            return;
         end if;

         O_L := Index (Line, """", O_F + 1);
         if O_L = 0
           or else (for some I in O_L + 1 .. Line'Last =>
                      not Is_In (Line (I), Whitespace))
         then
            Warn (+"suspicious configuration line::" & Line);
            return;
         end if;

         --  Now, split the extension list.
         declare
            Tool     : constant String
              := Line (P_F .. P_L) & ' ' & Line (O_F + 1 .. O_L - 1);
            Position : Tool_Maps.Cursor;
            Inserted : Boolean;
            First    : Positive := E_F;
            Last     : Natural;
         begin
            loop
               if E_L < First or else Line (First) = ',' then
                  Warn (+"suspicious configuration line::" & Line);
                  return;
               end if;
               Last := First;
               while Last < E_L and then Line (Last + 1) /= ',' loop
                  Last := Last + 1;
               end loop;
               Tools.Insert
                 (Key      => (if Options.Ignore_Extension_Case
                               then Translate (Line (First .. Last),
                                               Lower_Case_Map)
                               else (Line (First .. Last))),
                  New_Item => Tool,
                  Position => Position,
                  Inserted => Inserted);
               if not Inserted then
                  Warn (+"multiple tools given for extension: "
                          & Line (First .. Last));
               end if;
               exit when Last = E_L;
               First := Last + 2;
            end loop;
         end;
      end Parse_Line;

   begin
      if Ada.Environment_Variables.Exists ("HOME") then
         declare
            Home : constant String := Ada.Environment_Variables.Value ("HOME");
            Path : constant String
              := Ada.Directories.Compose (Home, User_Configuration);
         begin
            if Ada.Directories.Exists (Path) then
               Parse_File (Path);
               return;
            end if;
         end;
      else
         Warn (+"variable HOME not found in the environment");
      end if;

      if Ada.Directories.Exists (System_Configuration) then
         Parse_File (System_Configuration);
         return;
      end if;

      raise Error with +"No configuration file found: " & User_Configuration
        & ", " & System_Configuration;
   end Parse_Configuration;

   procedure Play_Songs (Commands : String_Vectors.Vector;
                         Options  : An_Option_List) is
      I         : Positive := (if Options.Eternal_Random
                                 then Random (Commands.Last_Index) else 1);
      Available : Boolean;
      Key       : Character;
   begin
      Songs : loop

         if not Options.Quiet then
            Ada.Text_IO.New_Line;
            Ada.Text_IO.Put_Line (+"music123 is running: " & Commands (I));
            Ada.Text_IO.Put_Line (+"Control-c : quit immediately");
            if Options.Catch_Q_In_Stdin then
               Ada.Text_IO.Put_Line (+"q         : quit after this song");
            end if;
            Ada.Text_IO.New_Line;
         end if;

         System (Commands (I));

         if Options.Catch_Q_In_Stdin then
            loop
               Ada.Text_IO.Get_Immediate (Key, Available);
               exit when not Available;
               exit Songs when Key in 'q' | 'Q';
            end loop;
         end if;

         if Options.Eternal_Random then
            I := Random (Commands.Last_Index);
         elsif I = Commands.Last_Index then
            exit Songs when not Options.Repeat;
            I := 1;
         else
            I := I + 1;
         end if;

         --  Only delay if there is a next song.
         delay Options.Delay_Length;

      end loop Songs;
   end Play_Songs;

   function Random (Maximum : Positive) return Positive is
      --  From ARM A.5.2.51.
      (Integer (Float (Maximum) * Random (Generator)) mod Maximum + 1);

   procedure Randomize (Commands : in out String_Vectors.Vector) is
   begin
      --  From Knuth, TAOCP vol. 2, edition 3, page 146, 3.4.2, algorithm P
      for J in reverse 2 .. Commands.Last_Index loop
         Commands.Swap (J, Random (J - 1));
      end loop;
   end Randomize;

   procedure Setlocale (Category : Interfaces.C.int;
                        Locale   : String) is
      use Interfaces.C, Interfaces.C.Strings;
      function F (A1 : int        := Category;
                  A2 : char_array := To_C (Locale)) return chars_ptr
        with Import, Convention => C, External_Name => "setlocale";
   begin
      if F = Null_Ptr then
         raise C_Error with "setlocale failed";
      end if;
   end Setlocale;

   procedure System (Command : String) is
      use Interfaces.C;
      function F (A1 : char_array := To_C (Command)) return int
        with Import, Convention => C, External_Name => "system";
   begin
      if F /= 0 then
         raise C_Error with "subprocess failed: " & Command;
      end if;
   end System;

   procedure Textdomain (Domainname : String) is
      use Interfaces.C, Interfaces.C.Strings;
      function F (A1 : char_array := To_C (Domainname)) return chars_ptr
        with Import, Convention => C, External_Name => "textdomain";
   begin
      if F = Null_Ptr then
         raise C_Error with "textdomain failed";
      end if;
   end Textdomain;

   procedure Warn (Message : String) is
   begin
      Ada.Text_IO.Put_Line (Ada.Text_IO.Standard_Error, Message);
   end Warn;

   ----------------------------------------------------------------------

   Paths    : String_Vectors.Vector;
   Options  : An_Option_List;
   Done     : Boolean;
   Tools    : Tool_Maps.Map;
   Commands : String_Vectors.Vector;
begin
   Setlocale (LC_ALL, "");
   Textdomain ("music123");
   Bindtextdomain ("music123", "/usr/share/locale");

   Reset (Generator);

   Parse_Command_Line (Paths, Options, Done);
   if Done then
      return;
   end if;

   Parse_Configuration (Tools, Options);

   for Path of Paths loop
      Add_Command (Commands, Path, Tools, Options);
   end loop;
   if Options.List_Files_Only then
      return;
   elsif Commands.Is_Empty then
      raise Error with +"No valid filenames found.";
   end if;

   if Options.Random then
      Randomize (Commands);
   end if;

   Play_Songs (Commands, Options);
end Music123;
