messages.adb


K------------------------------------------------------------------------------
--
--  package Messages (body)
--
------------------------------------------------------------------------------
--  Update information:
--
--  1996.04.25 (Jacob Sparre Andersen)
--    Written.
--
--  1996.05.12-13 (Jacob Sparre Andersen)
--    Finished the implementation.
--    There's a bug in the GNAT version of Ada.Strings.Unbounded.
--
--  1996.05.15 (Jacob Sparre Andersen)
--    Added function versions of Load.
--
--  1996.05.17 (Jacob Sparre Andersen)
--    Inserted debugging information.
--
--  1996.05.20 (Jacob Sparre Andersen)
--    Inserted debugging information.
--    Written Append_Message.
--
--  1996.06.19 (Jacob Sparre Andersen)
--    Exchanged the order of the formal parameters for the Load procedures.
--    Corrected and error in the logging system.
--
--  1996.07.09 (Jacob Sparre Andersen)
--    The bug in Ada.Strings.Unbounded.Delete has been corrected in GNAT 3.05.
--
--  1996.07.14 (Jacob Sparre Andersen)
--    Added more debugging messages.
--    Fixed procedure Put.
--    Exchanged Debugging with Debugged.
--
--  1996.07.16 (Jacob Sparre Andersen)
--    Found bug in procedure Put.
--    Exchanged Debugged with Debugging.
--    Extended the exception handling in procedure Put.
--    Exchanged Debugging with Debugged.
--
--  (Additional update information should be inserted above this line.)
------------------------------------------------------------------------------

with Ada.Characters.Latin_1;
with Ada.Strings.Fixed;

with Debugged;
with Trim_Special_Characters;
with UStrings;

package body Messages is

   use Debugged;

   ---------------------------------------------------------------------------
   --  Private constants:

   New_Line_Character : constant Character := Ada.Characters.Latin_1.CR;

   ---------------------------------------------------------------------------
   --  procedure Extract_ID (private):
   --
   --  Extracts a message ID from Name.

   procedure Extract_ID (Name  : in     String;
                         ID    :    out Message_ID_Type;
                         Valid :    out Boolean) is

   begin --  Extract_ID
      ID := Message_ID_Type'Value (Name);
      Valid := True;

      Message_Line ("Messages.Extract_ID: " & Name & " ~ " &
                      Message_ID_Type'Image (ID));
   exception
      when Constraint_Error =>
         Valid := False;
   end Extract_ID;

   ---------------------------------------------------------------------------
   --  procedure Load:
   --
   --  Reads a list of messages from Source.

   procedure Load (Source             : in     Ada.Text_IO.File_Type;
                   Messages           :    out Message_List;
                   Exception_On_Error : in     Boolean := False) is

      use Ada.Strings.Unbounded;

      Found_Invalid_ID : Boolean := False;

      Line     : Unbounded_String;
      ID       : Message_ID_Type;
      Is_Valid : Boolean;

   begin -- Load
      for Index in Messages'Range loop
         Messages(Index) := (Text => Null_Unbounded_String);
      end loop;

      while not Ada.Text_IO.End_Of_File (Source) loop
         UStrings.Get_Line (File => Source, Item => Line);

         if Length(Line) > 0 then
            if Index(Line, ":") > 0 then
               Extract_ID (Slice (Line, 1, Index (Line, ":") - 1),
                           ID,
                           Is_Valid);

               if Is_Valid then
                  Append (Messages (ID).Text,
                          Slice (Line, Index (Line, ":") + 1, Length (Line)));
                  Append (Messages (ID).Text,
                          New_Line_Character);
               else
                  Found_Invalid_ID := True;
               end if;
            end if;
         end if;
      end loop;

      for Index in Messages'Range loop
         if Messages(Index).Text = Null_Unbounded_String then
            Message_Line ("Messages.Load: No value is assigned to the " &
                            "message " & Message_ID_Type'Image (Index) & ".");
         else
            Message_Line ("Messages.Load: Message (" &
                            Message_ID_Type'Image (Index) & ") = """ &
                            To_String (Messages (Index).Text) & """.");
         end if;
      end loop;

      if Found_Invalid_ID and Exception_On_Error then
         raise Constraint_Error;
      end if;
   end Load;

   ---------------------------------------------------------------------------
   --  procedure Load:
   --
   --  Reads a list of messages from the file named Source_Name.

   procedure Load (Source_Name        : in     String;
                   Messages           :    out Message_List;
                   Exception_On_Error : in     Boolean := False) is

      use Ada.Text_IO;

      Source_File : File_Type;

   begin --  Load
      Message_Line ("Messages.Load: Opening " & Source_Name);

      Open (File => Source_File, Name => Source_Name, Mode => In_File);
      Load (Source_File, Messages, Exception_On_Error);
      Close (File => Source_File);

      Message_Line ("Messages.Load: Closed " & Source_Name);
   end Load;

   ---------------------------------------------------------------------------
   -- Load:

   function Load (Source             : in Ada.Text_IO.File_Type;
                  Exception_On_Error : in     Boolean := False)
     return Message_List is

      Result : Message_List;

   begin --
      Load (Source, Result, Exception_On_Error);
      return Result;
   end Load;

   ---------------------------------------------------------------------------
   -- Load:

   function Load (Source_Name        : in String;
                  Exception_On_Error : in     Boolean := False)
     return Message_List is

      Result : Message_List;

   begin --  Load
      Load (Source_Name, Result, Exception_On_Error);
      return Result;
   end Load;

   ---------------------------------------------------------------------------
   --  function Message:
   --
   --  Translates the raw message to a readable one using the variable parser
   --  Parse. The argument Trim is used to control whether spaces and special
   --  characters should be trimmed from the end of the message or not.
   --
   --  Exceptions:
   --    Constraint_Error  --  In case of un-even count of '$' in Raw_Message.
   --    (+ execptions propagated from Parse)

   function Message (Raw_Message : in Message_Type;
                     Trim        : in Boolean := False) return String is

      use Ada.Strings;
      use Ada.Strings.Unbounded;

      Raw    : Unbounded_String := Raw_Message.Text;
      Result : Unbounded_String;

   begin --  Message
      if Count (Raw, "$") rem 2 = 0 then
         while Index (Raw, "$") > 0 loop
            Append (Result, Slice (Raw, 1, Index (Raw, "$") - 1));
            Delete (Raw, From => 1, Through => Index (Raw, "$"));

            if Slice (Raw, 1, 1) = "$" then
               Append (Result, '$');
            else
               Message_Line ("Messages.Message: Parsing '" &
                               Slice (Raw, 1, Index (Raw, "$") - 1) & "'.");

               Append (Result, Parse (Slice (Raw, 1, Index (Raw, "$") - 1)));
               Delete (Raw, From => 1, Through => Index (Raw, "$"));
            end if;
         end loop;

         if Trim then
            return Trim_Special_Characters (To_String (Result & Raw), Both);
         else
            return To_String (Result & Raw);
         end if;
      else
         Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error,
                               "Messages.Message: Bad raw message.");
         raise Constraint_Error; --  Find a better one?
      end if;
   exception
      when Constraint_Error =>
         raise;
      when others =>
         Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error,
                               "Messages.Message: Unexpected exception.");
         raise;
   end Message;

   ---------------------------------------------------------------------------
   --  procedure Append_Message:
   --
   --  Exceptions:
   --    Constraint_Error  --  In case of un-even count of '$' in Raw_Message.
   --    (+ execptions propagated from Parse)

   procedure Append_Message
     (Target      : in out Ada.Strings.Unbounded.Unbounded_String;
      Raw_Message : in     Message_Type) is

      use Ada.Strings.Unbounded;

      Raw : Unbounded_String := Raw_Message.Text;

   begin --  Append_Message
      if Count (Raw, "$") rem 2 = 0 then
         while Index (Raw, "$") > 0 loop
            Append (Target, Slice (Raw, 1, Index (Raw, "$") - 1));
            Delete (Raw, From => 1, Through => Index (Raw, "$"));

            if Slice (Raw, 1, 1) = "$" then
               Append (Target, '$');
            else
               Message_Line ("Messages.Message: Parsing '" &
                               Slice (Raw, 1, Index (Raw, "$") - 1) & "'.");

            Parse_Variable:
               declare
               begin --  Parse_Variable
                  Append_Variable (Target,
                                   Slice (Raw, 1, Index (Raw, "$") - 1));
               exception
                  when others =>
                     Ada.Text_IO.Put_Line
                       (Ada.Text_IO.Current_Error,
                        "Messages.Append_Message.Parse_Variable: " &
                          "Unexpected exception from Append_Variable.");
                     raise;
               end Parse_Variable;

               Delete (Raw, From => 1, Through => Index (Raw, "$"));
            end if;
         end loop;
      else
         Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error,
                               "Messages.Message: Bad raw message.");
         raise Constraint_Error; -- Find a better one?
      end if;
   exception
      when Constraint_Error =>
         raise;
      when others =>
         Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error,
                               "Messages.Append_Message: Unexpected " &
                                 "exception.");
         raise;
   end Append_Message;

   ---------------------------------------------------------------------------
   --  procedure Put:

   procedure Put (File        : in     Ada.Text_IO.File_Type;
                  Raw_Message : in     Message_Type) is

      ------------------------------------------------------------------
      --  procedure Put_String:

      procedure Put_String (Item : in     String) is

         use Ada.Strings.Fixed;
         use Ada.Text_IO;

         First : Natural := Item'First;
         Last  : Natural := Index (Source  => Item,
                                   Pattern => (1 => New_Line_Character));

      begin --  Put_String
         Message_Line ("Messages.Put.Put_String (""" & Item & """)");
         Message_Line ("Messages.Put.Put_String: begin (a) ...");

         while (First in Item'Range) and (Last /= 0) loop
            Put_Line (File => File,
                      Item => Item (First .. Last - 1));

            First := Last + 1;
            Last  := Index (Source  => Item (First .. Item'Last),
                            Pattern => (1 => New_Line_Character));
         end loop;

         Message_Line ("Messages.Put.Put_String: (b)");

         if First in Item'Range then
            Put (File => File,
                 Item => Item (First .. Item'Last));
         end if;

         Message_Line ("Messages.Put.Put_String: (c) end.");
      end Put_String;

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

      use Ada.Strings;
      use Ada.Strings.Unbounded;

      Raw : Unbounded_String := Raw_Message.Text;

   begin --  Put
      Message_Line ("Messages.Put: begin ...");

      if Count (Raw, "$") rem 2 = 0 then
         Message_Line ("Messages.Put: (a)");

         while Index (Raw, "$") > 0 loop
            Message_Line ("Messages.Put: (b)");

            Message_Line ("Messages.Put: Writing '" &
                            Slice (Raw, 1, Index (Raw, "$") - 1) & "'.");

            Put_String (Slice (Raw, 1, Index (Raw, "$") - 1));

            Message_Line ("Messages.Put: (c)");

            Delete (Raw, From => 1, Through => Index (Raw, "$"));

            Message_Line ("Messages.Put: (d)");

            if Slice (Raw, 1, 1) = "$" then
               Message_Line ("Messages.Put: (e)");

               Put_String ("$");
            else
               Message_Line ("Messages.Put: (f)");

               Message_Line ("Messages.Put: Parsing '" &
                               Slice (Raw, 1, Index (Raw, "$") - 1) & "'.");

            Use_Parse:
               declare
               begin --  Use_Parse
                  Put_String (Parse (Slice (Raw, 1, Index (Raw, "$") - 1)));
               exception
                  when others =>
                     Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error,
                                           "Messages.Put: Parse raised an " &
                                             "exception.");
                     raise;
               end Use_Parse;

               Message_Line ("Messages.Put: (g)");

               Delete (Raw, From => 1, Through => Index (Raw, "$"));
            end if;

            Message_Line ("Messages.Put: (h)");
         end loop;

         Message_Line ("Messages.Put: (i)");

         Put_String (To_String (Raw));

         Message_Line ("Messages.Put: (j)");
      else
         Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error,
                               "Messages.Put: Bad raw message.");
         raise Constraint_Error; --  Find a better one?
      end if;

      Message_Line ("Messages.Put: end.");
   exception
      when Constraint_Error =>
         Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error,
                               "Messages.Put: Constraint error.");
         raise;
      when others =>
         Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error,
                               "Messages.Put: Unexpected exception.");
         raise;
   end Put;

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

end Messages;

Typeset with Ada_To_HTML (Jacob and Jesper)