-- DEC/CMS REPLACEMENT HISTORY, Element MSG_LOG.ADA -- *2 6-JUN-1991 16:27:49 ATVS "Added message passthrough" -- *1 30-MAY-1991 17:29:43 ATVS "Initial CMS Release" -- DEC/CMS REPLACEMENT HISTORY, Element MSG_LOG.ADA -- ===================================================================== -- >>>>>>>>>>>>>>>>>>>>>> ADA COMPILATION UNIT <<<<<<<<<<<<<<<<<<<<<<<<< -- ===================================================================== -- -- NAME: Msg_Log -- -- BODY -- -- SYSTEM: DEC VMS Operating System -- -- AUTHOR: Chuck Hobin -- -- DATE: 16 March 1990 -- -- CHANGE HISTORY -- -- ===================================================================== -- MM-DD-YY | Initials | Description -- --------------------------------------------------------------------- -- 06-05-91 CWH * Added PUT_LINE. -- * Modified PUT_MSG_INTERNAL -- 03-19-92 CWH Removed dependencies on Error_Utilities. Added -- Put_Msg_Debug, Set_Msg_Out_Status, -- Get_Msg_Out_Status. -- 04-09-92 CWH Added overloaded version of Put_Msg_Debug. -- 10-05-93 CWH Modified to reflect changes in spec. Changed -- header format. Added local procedure -- Put_Location. -- 02-23-94 CWH The Standard_Error file is now retrieved from -- Text_Io_Supplement. -- 07-24-94 CWH Local procedure Put_Msg no longer wraps the -- message text. -- ===================================================================== with Text_Io; use Text_Io; -- for visibility of "=" with Msg_Log_File; with Text_Io_Supplement; package body Msg_Log is -- This package provides operations for logging diagnostic messages -- generated by the using program, ensuring that all messages are -- handled in a uniform manner. -- In the implementation of this package, logged messages are -- "displayed" by writing them to a Text_IO file. Another library -- unit manages this file. -- Note that the operations of this package assume that the output -- file is open and is in Out_File mode. Max_Sys_Len : constant Integer := 7; -- maximum length for the subsystem string Subsystem : String (1 .. Max_Sys_Len); Subsystem_Len : Positive; -- flag to indicate whether a fatal or internal error has been -- started. Severity : Msg_Kind := None; -- Severity of the current message. Noise_Level : Msg_Kind := Listing; -- only messages with a Severity greater than this will be printed Max_Severity : Msg_Kind := None; -- maximum Severity enCountered. Tab : constant Integer := 8; Default_Len : constant Text_Io.Count := 80; Msg_Counts : array (Valid_Msg) of Natural := (others => 0); At_End_Of_Line : Boolean := False; Continuation_Line_Indent : constant := 5; -- If a message does not fit on one line of the output file, -- continuation lines will be indented to this column. Difference : constant := Character'Pos ('a') - Character'Pos ('A'); Msg_Out_Status : Msg_Out_Status_Enum := Msg_Out_Is_Standard_Error; ------------------------------------------------------------------------ -- LOCAL SUBPROGRAM DECLARATIONS ------------------------------------------------------------------------ function Upcase ( S : String) return String; function Msg_Out return Text_Io.File_Type; --| Current location of Msg_Out function Severity_Image (Kind : Valid_Msg) return String; procedure Put_Header ( --| prints out the header Kind : Valid_Msg; Id : String); function Max_Line_Len return Text_Io.Count; -- Returns the maximum line length of the output file. procedure Begin_Msg ( --| Start an error message Kind : in Valid_Msg; Id : in String); procedure Put_Msg ( --| Add a string to an error message. --| Break up at word boundaries if message too long; --| if not possible, then break word at end of line. Msg : String); procedure Put_Location (Lib_Unit : in String; Prog_Unit : in String); procedure End_Msg; ------------------------------------------------------------------------ -- EXPORTED SUBPROGRAM BODIES ------------------------------------------------------------------------ procedure Set_Program (Name : in String) is Len : constant Integer := Name'Length; begin Subsystem := (others => ' '); if Len <= Max_Sys_Len then Subsystem (1 .. Len) := Name; Subsystem_Len := Len; else Subsystem := Name (1 .. Max_Sys_Len); Subsystem_Len := Max_Sys_Len; end if; end Set_Program; ----------------------------------------------------------------------- procedure Set_Msg_Out_Status (Status : Msg_Out_Status_Enum) is begin Msg_Out_Status := Status; end Set_Msg_Out_Status; ----------------------------------------------------------------------- function Get_Msg_Out_Status return Msg_Out_Status_Enum is begin return Msg_Out_Status; end Get_Msg_Out_Status; ----------------------------------------------------------------------- procedure Set_Noise_Level (Level : in Msg_Kind) is begin Noise_Level := Level; end Set_Noise_Level; ----------------------------------------------------------------------- function Get_Noise_Level return Msg_Kind is begin return Noise_Level; end Get_Noise_Level; ----------------------------------------------------------------------- procedure Put_Msg (Kind : in Simple_Msg; Text : in String; Id : in String := "") is begin Begin_Msg (Kind, Id); Put_Msg (Text); End_Msg; end Put_Msg; ----------------------------------------------------------------------- procedure Put_Msg_Debug (Text : in String) is begin Put_Msg (Kind => Debug, Text => Text); end Put_Msg_Debug; ----------------------------------------------------------------------- procedure Put_Msg_Debug (Lib_Unit : in String; Prog_Unit : in String; Text : in String) is begin Begin_Msg (Debug, ""); Put_Msg (Text); Put_Location (Lib_Unit, Prog_Unit); End_Msg; end Put_Msg_Debug; ----------------------------------------------------------------------- procedure Put_Msg_Internal (Lib_Unit : in String; Prog_Unit : in String; Text : in String; Id : in String := "") is begin Begin_Msg (Internal, Id); Put_Msg (Text); Put_Location (Lib_Unit, Prog_Unit); End_Msg; end Put_Msg_Internal; ----------------------------------------------------------------------- procedure Put_Msg_Fatal (Lib_Unit : in String; Prog_Unit : in String; Text : in String; Id : in String := "") is begin Begin_Msg (Fatal, Id); Put_Msg (Text); Put_Location (Lib_Unit, Prog_Unit); End_Msg; end Put_Msg_Fatal; ----------------------------------------------------------------------- function Max_Severity_Seen return Msg_Kind is begin return Max_Severity; end Max_Severity_Seen; ----------------------------------------------------------------------- function Msg_Count (Kind : in Valid_Msg) return Natural is begin return Msg_Counts (Kind); end Msg_Count; ----------------------------------------------------------------------- procedure Reset_Msg_Info is begin Severity := None; Max_Severity := None; Msg_Counts := (others => 0); end Reset_Msg_Info; ----------------------------------------------------------------------- procedure Put_Line (Item : in String) is -- We invoke Begin_Msg in a special way to prevent the message -- header from being printed. We make the Severity 'Note' -- since we anticipate this operation being used to display -- information that supplements an error message. begin Begin_Msg (Note, "ADAQUEST_PASS_THROUGH"); Put_Msg (Item); End_Msg; end Put_Line; ------------------------------------------------------------------------ -- LOCAL SUBPROGRAM BODIES ------------------------------------------------------------------------ function Upcase ( S : String) return String is R : String (S'Range) := S; begin for I in R'Range loop case R (I) is when 'a' .. 'z' => R (I) := Character'Val (Character'Pos (R (I)) - Difference); when others => null; end case; end loop; return R; end Upcase; ----------------------------------------------------- function Msg_Out return Text_Io.File_Type is --| Return current file for message output begin case Msg_Out_Status is when Msg_Out_Is_Standard_Error => return Text_Io_Supplement.Standard_Error; when Msg_Out_Is_Standard_Output => return Text_Io.Standard_Output; when Msg_Out_Is_Default_Output => return Text_Io.Current_Output; when Msg_Out_Is_File => return Msg_Log_File.The_File; end case; end Msg_Out; ----------------------------------------------------- function Severity_Image ( --| Return "official" image of message severity Kind : Valid_Msg) return String is begin case Kind is when Fatal => return "fatal"; when Internal => return "internal"; when Error => return "error"; when Warning => return "warning"; when Note => return "note"; when Debug => return "debug"; when Id => return "ID"; when Timing => return "TIMING"; when Statistic => return "STATISTIC"; when Listing => return "LISTING"; end case; end Severity_Image; ----------------------------------------------------- procedure Put_Header ( --| prints out the header Kind : Valid_Msg; Id : String) is Tab_Amount : Integer; Column : Text_Io.Positive_Count; -- 10-5-93 The message format is changed to look like the following -- example: -- -- aq-error, This is sample message text -- -- The Id is not currently used (it is an artifact of VMS-style messages). begin if Id /= "" then Text_Io.Put (Msg_Out, Subsystem (1 .. Subsystem_Len) & "-" & Severity_Image (Kind) & ", "); else Text_Io.Put (Msg_Out, Subsystem (1 .. Subsystem_Len) & "-" & Severity_Image (Kind) & ", "); end if; -- Figure out what the next tab stop would be and set the -- column to that figure. -- Column := Text_IO.Col(Msg_Out); -- Tab_Amount := (integer(Column) / Tab) + 1; -- Text_IO.Set_Col(Msg_Out, Text_IO.Positive_Count(Tab*Tab_Amount+1)); At_End_Of_Line := False; end Put_Header; ----------------------------------------------------- function Max_Line_Len return Text_Io.Count is -- Returns the maximum line length of the output file. Line_Len : Text_Io.Count; begin Line_Len := Text_Io.Line_Length (Msg_Out); if Line_Len = 0 then -- The file has no line size limit - use Default_Len. return Default_Len; else return Line_Len; end if; end Max_Line_Len; ----------------------------------------------------- procedure Begin_Msg ( --| Start an error message Kind : in Valid_Msg; Id : in String) is Pass_Through : Boolean; begin if Severity /= None then -- this means that end_Msg has not been called for the previous -- message. Text_Io.New_Line (Msg_Out); -- this is because end_Msg is the routine that finishes a message -- with the new line. Text_Io.Put_Line (Msg_Out, "ERROR The previous message did not call end_Msg."); -- this must be printed directly to avoid the possibility of -- an infinite loop. end if; Severity := Kind; Pass_Through := Kind = Note and then Id = "ADAQUEST_PASS_THROUGH"; if not Pass_Through then Msg_Counts (Kind) := Msg_Counts (Kind) + 1; if Valid_Msg'Pos (Severity) > Valid_Msg'Pos (Max_Severity) then Max_Severity := Severity; end if; end if; if Noise_Level = None then return; end if; -- Note: This procedure is not going to check that the Subsystem -- etc are less than Max_Line_Len since it would be ridiculous to -- have a beginning bigger than 80 characters. if Severity >= Noise_Level then if not Pass_Through then Put_Header (Kind, Id); end if; end if; end Begin_Msg; ----------------------------------------------------- procedure Put_Msg ( --| Add a string to an error message. --| Break up at word boundaries if message too long; --| if not possible, then break word at end of line. Msg : String) is Msg_Next : Natural := Msg'First; --| Start of (rest of) message Msg_Last : constant Natural := Msg'Last; --| End of message To_Be_Put : Natural; --| Count of chars to be put out on one line begin if Severity = None then -- directly write the error message to avoid the possibility of -- an infinite loop. Text_Io.Put (Msg_Out, "ERROR error message not begun with a begin_Msg"); end if; if Noise_Level = None then return; end if; if Severity >= Noise_Level then Text_Io.Put (Msg_Out, Msg); end if; end Put_Msg; ----------------------------------------------------- procedure Put_Location (Lib_Unit : in String; Prog_Unit : in String) is begin if Noise_Level /= None and then Severity >= Noise_Level then Text_Io.New_Line (Msg_Out); Text_Io.Set_Col (Msg_Out, Continuation_Line_Indent); Text_Io.Put (Msg_Out, "** Lib Unit => " & Lib_Unit); Text_Io.New_Line (Msg_Out); Text_Io.Set_Col (Msg_Out, Continuation_Line_Indent); Text_Io.Put (Msg_Out, "** Prog Unit => " & Prog_Unit); -- End_Msg does the final New_Line. end if; end Put_Location; ----------------------------------------------------- procedure End_Msg is --| Finish error message begin if Noise_Level /= None and then Severity >= Noise_Level then Text_Io.New_Line (Msg_Out); end if; case Severity is when Fatal => Severity := None; raise Fatal_Error; when others => Severity := None; end case; end End_Msg; ----------------------------------------------------- end Msg_Log;