messages
messages.ads
messages.adb
messages
messages
user_interface
util
hash_tables/
heaps/
images/
lists/
maths/
messages/
pipes/
primes/
readers/
strings/
writers/
ada
bin/
engine/
fonts/
internal/
text/
util/
Home
Showcase
Snapshots
Ada Source
PHP Source
Fonts
Sourceforge
Summary
Downloads
Browse CVS
Donate
Activity

Hosted by
SourceForge.net Logo

 -- $Date: 2004/02/23 08:45:48 $
-- $Revision: 1.10 $
-- $Author: jcrocholl $

with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;

with Strings; use Strings;
with String_Tools; use String_Tools;

package body Messages is

   -- Name of the program executable, without extension.
   Program_Name : String_Access;

   -- User doesn't want status messages.
   Quiet : Boolean := False;

   -- Print a message to error output, followed by a newline.
   procedure Debug
     (Text : in String) is -- Print this message.
   begin
      Put_Line(Ada.Text_IO.Current_Error, Text);
   end Debug;

   -- Print a message to error output, no newline.
   procedure Debug2
     (Text : in String) is -- Print this message.
   begin
      Put(Ada.Text_IO.Current_Error, Text);
   end Debug2;

   -- If not in quiet mode, print the program name (if non-empty) and
   -- the message text to error output, followed by a newline.
   procedure Message
     (Text : in String) is -- Print this message.
   begin
      if not Quiet then
         if not Is_Null(Program_Name)
         then Put_Line(Ada.Text_IO.Current_Error, To_String(Program_Name) & ": " & Text);
         else Put_Line(Ada.Text_IO.Current_Error, Text);
         end if;
      end if;
   end Message;

   -- Print the program name (if non-empty) and the error message text
   -- to error output, followed by a newline. Set exit status to
   -- failure.
   procedure Error
     (Text : in String) is -- Print this error message.
   begin
      if not Is_Null(Program_Name)
      then Put_Line(Ada.Text_IO.Current_Error, To_String(Program_Name) & ": " & Text);
      else Put_Line(Ada.Text_IO.Current_Error, Text);
      end if;
      Set_Exit_Status(Failure);
   end Error;

   -- Print a formatted error message for an exception.
   procedure Error
     (E : in Exception_Occurrence) -- Print this exception message.
   is
      Name    : String := Suffix_After_Char(Exception_Name(E), '.');
      Message : String := Exception_Message(E);
   begin
      To_Lower(Name);
      Replace_Char(Name, '_', ' ');
      Error(Name & ": " & Message);
   end Error;

   procedure Set_Program_Name
     (Program_Name : in String) is
   begin
      To_String_Access(Program_Name, Messages.Program_Name);
   end Set_Program_Name;

   function Get_Program_Name
     return String is
   begin
      return To_String(Program_Name);
   end Get_Program_Name;

   procedure Set_Quiet
     (Quiet : in Boolean) is
   begin
      Messages.Quiet := Quiet;
   end Set_Quiet;

   function Get_Quiet
     return Boolean is
   begin
      return Quiet;
   end Get_Quiet;

end Messages;