------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2001-2022, AdaCore -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ pragma Ada_2012; with Ada.Calendar; use Ada.Calendar; with Ada.Calendar.Formatting; use Ada.Calendar.Formatting; with Ada.Calendar.Time_Zones; use Ada.Calendar.Time_Zones; with Ada.Environment_Variables; with Ada.Strings.Fixed; use Ada.Strings.Fixed; with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; with Ada.IO_Exceptions; with Ada.Unchecked_Deallocation; with GNAT.Calendar.Time_IO; use GNAT.Calendar.Time_IO; with GNAT.OS_Lib; use GNAT.OS_Lib; with GNAT.Regpat; use GNAT.Regpat; with GNAT.Traceback; use GNAT.Traceback; with Interfaces.C_Streams; use Interfaces.C_Streams; with System.Address_Image; with System.Assertions; use System.Assertions; with GNATCOLL.Memory; with GNATCOLL.Mmap; use GNATCOLL.Mmap; with GNATCOLL.Templates; with GNATCOLL.Utils; use GNATCOLL.Utils; package body GNATCOLL.Traces is use type FILEs, size_t; use type GNATCOLL.Terminal.ANSI_Color, GNATCOLL.Terminal.ANSI_Style; use type GNATCOLL.Terminal.Full_Style; Max_Active_Decorators : constant := 40; -- Maximum number of active iterators On_Exception : On_Exception_Mode := Propagate; -- The behavior that should be adopted when something unexpected prevent -- the log stream to be written. -- Note: rev 1.5 of this file has a (disabled) support for symbolic -- tracebacks. -- ??? We could display the stack pointer with -- procedure Print_Sp is -- start : aliased Integer; -- begin -- Put_Line (System.Address_Image (Start'Address)); -- end; A_Zero : aliased constant String := "a" & ASCII.NUL; W_Zero : aliased constant String := "w" & ASCII.NUL; Reset_All : constant String := GNATCOLL.Terminal.Get_ANSI_Sequence ((Style => GNATCOLL.Terminal.Reset_All, Fg => GNATCOLL.Terminal.Unchanged, Bg => GNATCOLL.Terminal.Unchanged)); Default_Style : constant Message_Style := (Fg => GNATCOLL.Terminal.Reset, Bg => GNATCOLL.Terminal.Unchanged, Style => GNATCOLL.Terminal.Unchanged); -- The default style used for handles. This uses the terminal's -- default foreground. Default_Exception_Style : constant Message_Style := (Fg => GNATCOLL.Terminal.Black, Bg => GNATCOLL.Terminal.Red, Style => GNATCOLL.Terminal.Unchanged); -- Highlight with a red background. -- This is used to report unexpected exceptions when an exception -- occurrence is passed to Trace. type Decorator_Array is array (1 .. Max_Active_Decorators) of Trace_Decorator; procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Trace_Handle_Record'Class, Trace_Handle); procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Trace_Stream_Record'Class, Trace_Stream); type Stream_Factories; type Stream_Factories_List is access Stream_Factories; type Stream_Factories is record Name : GNAT.Strings.String_Access; Factory : Stream_Factory_Access; Next : Stream_Factories_List; end record; procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Stream_Factories, Stream_Factories_List); procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Stream_Factory'Class, Stream_Factory_Access); type Global_Vars is record Handles_List : Trace_Handle := null; -- The global list of all defined handles. Active_Decorators : Decorator_Array; Active_Last : Natural := 0; -- Never null after parsing the config file. -- Decorators on this list are all active, and also stored in the -- Handles_List. Wildcard_Handles_List : Trace_Handle := null; -- Contains the configuration for module names containing stars, for -- instance "*.EXCEPTIONS". Streams_List : Trace_Stream := null; -- The global list of all streams. -- The default stream is the first in the list. Factories_List : Stream_Factories_List := null; -- The global list of all factories. TZ : Time_Offset := UTC_Time_Offset; -- Time zone cache, assuming that the OS will not change time zones -- while this partition is running. Lock : aliased Atomic_Counter := 0; pragma Atomic (Lock); Absolute_Time : Trace_Decorator; Absolute_Date : Trace_Decorator; Micro_Time : Trace_Decorator; Colors : Trace_Decorator; Enclosing_Entity : Trace_Decorator; Location : Trace_Decorator; Finalize_Traces : Trace_Decorator; Split_Lines : Trace_Decorator; -- The predefined decorators. -- ??? These are also stored in the lists above, so we might not need -- them. Default_Activation : Boolean := False; -- Default activation status for debug handles (ie whether the -- configuration file contained "+"). -- ??? Could be handled via a "*" star handle Finalized : Boolean := False; -- Whether the package has been finalized. -- When this is true, some trace_handles will have been freed, and it -- is therefore illegal to access them. end record; Global : Global_Vars; type Elapse_Time_Trace is new Trace_Decorator_Record with null record; overriding procedure After_Message (Self : in out Elapse_Time_Trace; Handle : not null Logger; Msg : in out Msg_Strings.XString); type Stack_Trace is new Trace_Decorator_Record with null record; overriding procedure After_Message (Self : in out Stack_Trace; Handle : not null Logger; Msg : in out Msg_Strings.XString); type Count_Trace is new Trace_Decorator_Record with null record; overriding procedure Before_Message (Self : in out Count_Trace; Handle : not null Logger; Msg : in out Msg_Strings.XString); type Memory_Trace is new Trace_Decorator_Record with record Previous : GNATCOLL.Memory.Byte_Count := 0; end record; overriding procedure After_Message (Self : in out Memory_Trace; Handle : not null Logger; Msg : in out Msg_Strings.XString); type Ada_Memory_Trace is new Trace_Decorator_Record with record Previous : GNATCOLL.Memory.Byte_Count := 0; end record; overriding procedure After_Message (Self : in out Ada_Memory_Trace; Handle : not null Logger; Msg : in out Msg_Strings.XString); procedure Lock (The_Lock : aliased in out Atomic_Counter) with Inline_Always; procedure Unlock (The_Lock : aliased in out Atomic_Counter) with Inline_Always; -- For critical regions. A thread already owning the lock cannot try to -- take the lock again, or it will block. procedure Create_Exception_Handle (Handle : not null Trace_Handle); -- Create the exception handle associated with Handle. function Local_Sub_Second (T : Ada.Calendar.Time) return Integer; pragma Inline (Local_Sub_Second); -- Version of Local_Sub_Second taking advantage of the timezone cache -- return values in range 0 .. 999 function Find_Handle (Handle : Trace_Handle; Name_Upper_Case : String) return Trace_Handle; -- Return the debug handle associated with Unit_Name_Upper_Case, -- or null if there is none. The case of Unit_Name_Upper_Case is -- not changed. -- Note: this subprogram doesn't do any locking, it is the -- responsability of the called to make sure that not two tasks -- can access it at the same time. function Find_Wildcard_Handle (Unit_Name_Upper_Case : String) return Trace_Handle; -- Check whether there is a module name that contains a "*" and that can be -- used to provide the default configuration for Unit_Name_Upper_Case function Wildcard_Applies_To (Upper_Name : String; Upper_Star : String) return Boolean; -- Whether the module Upper_Name should take its default configuration from -- Upper_Wildcard_Name. function Find_Stream (Stream_Name : String; Relative_Path_To : Virtual_File; Append : Boolean) return Trace_Stream; -- Return the stream associated with that name (either an existing one or -- one created by a factory), or null if the default stream should be -- applied. -- The Stream_Name might include the settings for the stream, as in: -- "file.txt:buffer_size=0,async=true" procedure Put_Absolute_Time (Msg : in out Msg_Strings.XString); -- Print the absolute time in Handle. No locking is done, this is the -- responsability of the caller. No colors is modified either. function Config_File (Filename : Virtual_File; Default : Virtual_File) return Virtual_File; -- Return the name of the config file to use. -- If Filename is specified, this is the file to use, providing it exists. -- Otherwise, we use a .gnatdebug in the current directory, and if there is -- none, Default if it exists. -- The empty string is returned if no such file was found. procedure Register_Handle (Handle : not null Trace_Handle; Upper_Case : String; Finalize : Boolean := True); -- add Handle to the internal list and set default fields function Create_Internal (Unit_Name : String; Default : Default_Activation_Status := From_Config; Stream : Trace_Stream; Factory : Handle_Factory := null; Finalize : Boolean := True; Style : Message_Style; From_Config_File : Boolean) return Trace_Handle; -- Internal version of Create function Get_Process_Id return Integer; -- Return the process ID of the current process pragma Import (C, Get_Process_Id, "getpid"); type File_Stream_Record is new Trace_Stream_Record with record File : FILEs := NULL_Stream; Lock : aliased GNATCOLL.Atomic.Atomic_Counter := 0; Colors_Support : Boolean; File_Name : GNAT.Strings.String_Access; -- The absolute path of the file associated to this stream, if any. end record; overriding procedure Put (Stream : in out File_Stream_Record; Str : Msg_Strings.XString); overriding procedure Close (Stream : in out File_Stream_Record); overriding function Supports_Color (Self : File_Stream_Record) return Boolean is (Self.Colors_Support); -- Logs to a file procedure Cache_Settings (Handle : not null Trace_Handle); -- Cache various settings in Handle, to avoid dispatching calls in Log -- and thus speed things up. -- These settings are changed much less frequently. ---------- -- Lock -- ---------- procedure Lock (The_Lock : aliased in out Atomic_Counter) is begin while True loop -- In this package, the lock is owned during the time it takes -- to Put a string to a stream (async streams go even faster). -- It doesn't seem worth adding a "delay" in this loop, though -- the standard implementation would be to have a delay on a -- random number, and increase the delay every time we have to -- loop until a given maximum. while The_Lock /= 0 loop null; end loop; exit when Sync_Add_And_Fetch (The_Lock'Unchecked_Access, 1) = 1; end loop; end Lock; ------------ -- Unlock -- ------------ procedure Unlock (The_Lock : aliased in out Atomic_Counter) is begin The_Lock := 0; end Unlock; ----------------- -- Find_Handle -- ----------------- function Find_Handle (Handle : Trace_Handle; Name_Upper_Case : String) return Trace_Handle is Tmp : Trace_Handle := Handle; begin while Tmp /= null and then Tmp.Name.all /= Name_Upper_Case loop Tmp := Tmp.Next; end loop; return Tmp; end Find_Handle; ------------------------- -- Wildcard_Applies_To -- ------------------------- function Wildcard_Applies_To (Upper_Name : String; Upper_Star : String) return Boolean is begin if Upper_Star (Upper_Star'First) = '*' then -- Test must include '.' in the suffix if Ends_With (Upper_Name, Upper_Star (Upper_Star'First + 1 .. Upper_Star'Last)) then return True; end if; elsif Upper_Star (Upper_Star'Last) = '*' then -- "MODULE.*" should include "MODULE" itself if Upper_Name = Upper_Star (Upper_Star'First .. Upper_Star'Last - 2) then return True; end if; -- Otherwise "MODULE.*" should match "MODULE.FOO" but not -- MODULEFOO.BAR if Starts_With (Upper_Name, Upper_Star (Upper_Star'First .. Upper_Star'Last - 1)) then return True; end if; end if; return False; end Wildcard_Applies_To; -------------------------- -- Find_Wildcard_Handle -- -------------------------- function Find_Wildcard_Handle (Unit_Name_Upper_Case : String) return Trace_Handle is Tmp : Trace_Handle := Global.Wildcard_Handles_List; begin while Tmp /= null loop if Wildcard_Applies_To (Upper_Name => Unit_Name_Upper_Case, Upper_Star => Tmp.Name.all) then return Tmp; end if; Tmp := Tmp.Next; end loop; return null; end Find_Wildcard_Handle; ------------------------ -- Show_Configuration -- ------------------------ procedure Show_Configuration (Output : Output_Proc) is Tmp : Trace_Handle := Global.Handles_List; function Stream_Name return String; -- Return the name of the stream if there is one function Stream_Name return String is begin if Tmp.Stream /= null and then Tmp.Stream /= Global.Streams_List then return " >" & Tmp.Stream.Name.all; else return ""; end if; end Stream_Name; begin if Global.Streams_List /= null then Output ("> " & Global.Streams_List.Name.all); end if; while Tmp /= null loop if Tmp.Active then Output (Tmp.Name.all & "=yes" & Stream_Name); elsif Tmp.all not in Trace_Decorator_Record'Class then -- Only output decorators when they are active Output (Tmp.Name.all & "=no" & Stream_Name); end if; Tmp := Tmp.Next; end loop; end Show_Configuration; ----------------- -- Find_Stream -- ----------------- function Find_Stream (Stream_Name : String; Relative_Path_To : Virtual_File; Append : Boolean) return Trace_Stream is procedure Add_To_Streams (Tmp : Trace_Stream); -------------------- -- Add_To_Streams -- -------------------- procedure Add_To_Streams (Tmp : Trace_Stream) is begin -- ??? Could use atomic operations to manipulate the -- list directly. Lock (Global.Lock); -- If possible, do not put this first on the list of streams, -- since it would become the default stream if Global.Streams_List = null then Global.Streams_List := Tmp; Tmp.Next := null; else Tmp.Next := Global.Streams_List.Next; Global.Streams_List.Next := Tmp; end if; Unlock (Global.Lock); end Add_To_Streams; Name : constant String := Trim (Stream_Name, Ada.Strings.Both); Tmp : Trace_Stream; Colon : Natural; TmpF : Stream_Factories_List; Default_Colors : GNATCOLL.Terminal.Supports_Color := GNATCOLL.Terminal.Auto; Term : GNATCOLL.Terminal.Terminal_Info; Supports_Buffer : Boolean := True; Buf_Size : size_t := 1; -- Line buffering by default begin if Name = "" then return null; end if; -- Do we have a matching existing stream? -- Since we use a linked list and never remove elements from -- the list, we do not need locking. Tmp := Global.Streams_List; while Tmp /= null loop if Tmp.Name.all = Name then return Tmp; end if; Tmp := Tmp.Next; end loop; -- Parse stream options Colon := Index (Name, ":"); if Colon < Name'First then Colon := Name'Last + 1; end if; declare Args : String_List_Access := Split (Name, ':'); begin for A of Args (Args'First + 1 .. Args'Last) loop if Starts_With (A.all, "buffer_size=") then begin Buf_Size := size_t'Value (A (A'First + 12 .. A'Last)); exception when Constraint_Error => -- Ignore not numeric buffer_size value and Buf_Size -- remains default. null; end; elsif Starts_With (A.all, "colors=") then declare V : constant String := To_Lower (A (A'First + 7 .. A'Last)); begin if V = "on" or else V = "true" then Default_Colors := GNATCOLL.Terminal.Yes; elsif V = "off" or else V = "false" then Default_Colors := GNATCOLL.Terminal.No; else Default_Colors := GNATCOLL.Terminal.Auto; end if; end; end if; end loop; Free (Args); end; -- Do we have a matching factory (if we start with "&")? if Name (Name'First .. Colon - 1) = "&1" then Term.Init_For_Stdout (Colors => Default_Colors); Tmp := new File_Stream_Record' (Name => new String'(Name), File => stdout, Colors_Support => Term.Has_ANSI_Colors, others => <>); Add_To_Streams (Tmp); Supports_Buffer := False; elsif Name (Name'First .. Colon - 1) = "&2" then Term.Init_For_Stderr (Colors => Default_Colors); Tmp := new File_Stream_Record' (Name => new String'(Name), File => stderr, Colors_Support => Term.Has_ANSI_Colors, others => <>); Add_To_Streams (Tmp); Supports_Buffer := False; elsif Name (Name'First) = '&' then Tmp := null; TmpF := Global.Factories_List; while TmpF /= null loop if TmpF.Name.all = Name (Name'First .. Colon - 1) then if Colon < Name'Last then Tmp := TmpF.Factory.New_Stream (Name (Colon + 1 .. Name'Last)); else Tmp := TmpF.Factory.New_Stream (""); end if; Tmp.Name := new String'(Name); Add_To_Streams (Tmp); exit; end if; TmpF := TmpF.Next; end loop; else declare use GNATCOLL.Templates; Now : constant Ada.Calendar.Time := Clock; Nam_Dollar : aliased String := "$"; Val_Dollar : aliased String := Trim (Get_Process_Id'Img, Ada.Strings.Both); Nam_D : aliased String := "D"; Val_D : aliased String := Image (Now, ISO_Date); Nam_T : aliased String := "T"; Val_T : aliased String := Val_D & Image (Now, "T%H%M%S"); Predef_Substitutions : constant Substitution_Array := ((Name => Nam_Dollar'Unchecked_Access, Value => Val_Dollar'Unchecked_Access), (Name => Nam_D'Unchecked_Access, Value => Val_D'Unchecked_Access), (Name => Nam_T'Unchecked_Access, Value => Val_T'Unchecked_Access)); function Substitute_Cb (Var : String; Quoted : Boolean) return String; -- Callback for variable substitution in Name -------------------- -- Substitute_Cb -- -------------------- function Substitute_Cb (Var : String; Quoted : Boolean) return String is pragma Unreferenced (Quoted); -- No way to "use Ada.Environment_Variables;" because of -- visibility conflict with Traces.Exists and GNAT can't -- discover it, see R924-001. begin if Ada.Environment_Variables.Exists (Var) then return Ada.Environment_Variables.Value (Var); else raise Invalid_Substitution; end if; end Substitute_Cb; N : constant String := Normalize_Pathname (Substitute (Str => Name (Name'First .. Colon - 1), Substrings => Predef_Substitutions, Callback => Substitute_Cb'Unrestricted_Access, Delimiter => '$'), +Relative_Path_To.Full_Name.all); N_Zero : aliased constant String := N & ASCII.NUL; F : FILEs; begin if Append then F := fopen (N_Zero'Address, mode => A_Zero'Address); else F := fopen (N_Zero'Address, mode => W_Zero'Address); end if; if F = NULL_Stream then F := stderr; end if; Term.Init_For_File (Colors => Default_Colors); Tmp := new File_Stream_Record' (Name => new String'(Name), File => F, Colors_Support => Term.Has_ANSI_Colors, File_Name => new String'(N), others => <>); Add_To_Streams (Tmp); end; end if; if Tmp /= null and then Tmp.all in File_Stream_Record'Class and then Supports_Buffer then declare Dummy : int; begin Dummy := setvbuf (File_Stream_Record (Tmp.all).File, System.Null_Address, (case Buf_Size is when 0 => IONBF, -- unbuffered when 1 => IOLBF, -- line buffered when others => IOFBF), -- full buffered Buf_Size); end; end if; -- Else use the default stream return Tmp; end Find_Stream; --------------------- -- Get_Stream_File -- --------------------- function Get_Stream_File (Handle : not null access Trace_Handle_Record'Class) return Virtual_File is begin if Handle.Stream /= null and then Handle.Stream.all in File_Stream_Record'Class and then File_Stream_Record (Handle.Stream.all).File_Name /= null then return Create (+File_Stream_Record (Handle.Stream.all).File_Name.all); end if; return No_File; end Get_Stream_File; ------------ -- Create -- ------------ function Create (Unit_Name : String; Default : Default_Activation_Status := From_Config; Stream : String := ""; Factory : Handle_Factory := null; Finalize : Boolean := True) return Trace_Handle is begin return Create_Internal (From_Config_File => False, Unit_Name => Unit_Name, Default => Default, Stream => Find_Stream (Stream, No_File, Append => False), Factory => Factory, Style => Default_Style, Finalize => Finalize); end Create; --------------------- -- Create_Internal -- --------------------- function Create_Internal (Unit_Name : String; Default : Default_Activation_Status := From_Config; Stream : Trace_Stream; Factory : Handle_Factory := null; Finalize : Boolean := True; Style : Message_Style; From_Config_File : Boolean) return Trace_Handle is Is_Star : constant Boolean := Starts_With (Unit_Name, "*.") or else Ends_With (Unit_Name, ".*"); Handle : Trace_Handle; Upper_Case : constant String := To_Upper (Unit_Name); Tmp2 : Trace_Handle; Wildcard : Trace_Handle; begin -- Do we already have an existing handle ? Handle := Find_Handle ((if Is_Star then Global.Wildcard_Handles_List else Global.Handles_List), Upper_Case); if Handle = null then if Factory /= null then Handle := Factory.all; end if; if Handle = null then Handle := new Trace_Handle_Record; end if; Register_Handle (Handle => Handle, Upper_Case => Upper_Case, Finalize => Finalize); -- Unless both settings are already known, check if we have a -- wildcard. if (Default = From_Config or else Stream = null) and then not Is_Star then Wildcard := Find_Wildcard_Handle (Handle.Name.all); if Wildcard /= null then Set_Active (Handle, Wildcard.Active); Handle.Forced_Active := True; -- Unless we specified an explicit stream, inherit it if Stream = null and then Wildcard.Stream /= null then Handle.Stream := Wildcard.Stream; Handle.Stream_Is_Default := Wildcard.Stream_Is_Default; end if; else Set_Active (Handle, Global.Default_Activation); end if; end if; end if; if Stream /= null then -- Only override when we are parsing the configuration file, so -- that if we have the following: -- Me : Trace_Handle := Create ("ME", Stream => "str1"); -- parse config file, which contains "ME=yes >str2" -- Me := Create ("ME", Stream => "str3") -- then "ME" is sent to "str2" (priority is given to the config -- file. if From_Config_File or else Handle.Stream_Is_Default then Handle.Stream := Stream; Handle.Stream_Is_Default := False; end if; -- A wildcard only impacts the stream of loggers if it has its own -- stream. elsif not Is_Star then -- Use the default stream. If we are still parsing the config -- file, we might not have this info yet, so we set Stream to -- 'null' and it will be overridden later if not From_Config_File and then Handle.Stream_Is_Default then Handle.Stream := Global.Streams_List; Handle.Stream_Is_Default := True; end if; end if; -- Set activation if not Handle.Forced_Active or else From_Config_File then case Default is when On => Handle.Forced_Active := True; Set_Active (Handle, Active => True); when Off => Handle.Forced_Active := True; Set_Active (Handle, Active => False); when From_Config => null; end case; end if; -- If we are declaring a "wildcard" handle, we need to check -- whether any existing handle would match (which will in -- general be the case, since handles are declared at -- elaboration time and star handles in the config file). if Is_Star then Tmp2 := Global.Handles_List; while Tmp2 /= null loop if Wildcard_Applies_To (Tmp2.Name.all, Upper_Star => Handle.Name.all) then -- Always override the status of matching streams: -- There are two scenarios here: -- - in a given config file, we always respect the order -- of declarations, thus wildcards should in general be put -- at the beginning. -- - if a wildcard is declared later on in Ada, we want -- it to impact existing streams as well (as a convenience -- for forcing specific settings from the code. -- -- So do not check Tmp2.Forced_Active Set_Active (Tmp2, Handle.Active); if Style /= Use_Default_Style and then Tmp2.Default_Style = Default_Style then Tmp2.Default_Style := Style; end if; if Tmp2.Stream_Is_Default and then Handle.Stream /= null then Tmp2.Stream := Handle.Stream; Tmp2.Stream_Is_Default := Handle.Stream_Is_Default; end if; end if; Tmp2 := Tmp2.Next; end loop; end if; if Style /= Use_Default_Style then Handle.Default_Style := Style; end if; Cache_Settings (Handle); return Handle; end Create_Internal; ------------ -- Exists -- ------------ function Exists (Unit_Name : String) return Boolean is Is_Star : constant Boolean := Starts_With (Unit_Name, "*.") or else Ends_With (Unit_Name, ".*"); Handle : Trace_Handle; Upper_Case : constant String := To_Upper (Unit_Name); begin Handle := Find_Handle ((if Is_Star then Global.Wildcard_Handles_List else Global.Handles_List), Upper_Case); return Handle /= null; end Exists; -------------------- -- Cache_Settings -- -------------------- procedure Cache_Settings (Handle : not null Trace_Handle) is begin -- If we have already registered the default decorators if Global.Colors /= null and then Handle.Stream /= null then Handle.With_Time := (Global.Absolute_Time.Active or else Global.Absolute_Date.Active) and then Handle.Stream.Supports_Time; Handle.With_Colors := Global.Colors.Active and then Handle.Stream.Supports_Color; end if; end Cache_Settings; --------------------- -- Register_Handle -- --------------------- procedure Register_Handle (Handle : not null Trace_Handle; Upper_Case : String; Finalize : Boolean := True) is Is_Star : constant Boolean := Starts_With (Upper_Case, "*.") or else Ends_With (Upper_Case, ".*"); begin Handle.Name := new String'(Upper_Case); Handle.Forced_Active := False; Handle.Count := 0; Handle.Timer := No_Time; Handle.Finalize := Finalize; Handle.Active := False; Handle.Stream_Is_Default := True; Lock (Global.Lock); if Is_Star then Handle.Next := Global.Wildcard_Handles_List; Global.Wildcard_Handles_List := Handle; else Handle.Next := Global.Handles_List; Global.Handles_List := Handle; end if; Unlock (Global.Lock); exception when others => Unlock (Global.Lock); raise; end Register_Handle; ---------------- -- Set_Active -- ---------------- procedure Set_Active (Handle : not null access Trace_Handle_Record'Class; Active : Boolean) is Tmp : Trace_Handle; Dec : Trace_Decorator; begin Handle.Active := Active; if Handle.all in Trace_Decorator_Record'Class then Dec := Trace_Decorator (Handle); if Dec /= Global.Colors and then Dec /= Global.Finalize_Traces and then Dec /= Global.Split_Lines then -- If active, store it in the list of active decorators if Active then for A in 1 .. Global.Active_Last loop if Global.Active_Decorators (A) = Dec then -- Already in the list return; end if; end loop; -- ??? Should check if we have too many decorators Global.Active_Last := Global.Active_Last + 1; Global.Active_Decorators (Global.Active_Last) := Dec; else for A in 1 .. Global.Active_Last loop if Global.Active_Decorators (A) = Dec then Global.Active_Decorators (A .. Global.Active_Last - 1) := Global.Active_Decorators (A + 1 .. Global.Active_Last); Global.Active_Last := Global.Active_Last - 1; exit; end if; end loop; end if; end if; if Dec = Global.Colors or else Dec = Global.Absolute_Time or else Dec = Global.Absolute_Date then Tmp := Global.Handles_List; while Tmp /= null loop Cache_Settings (Tmp); Tmp := Tmp.Next; end loop; end if; end if; end Set_Active; --------------- -- Is_Active -- --------------- function Is_Active (Handle : not null access Trace_Handle_Record'Class) return Boolean is begin return not Global.Finalized and then Handle.Active; end Is_Active; --------------- -- Unit_Name -- --------------- function Unit_Name (Handle : not null access Trace_Handle_Record'Class) return String is begin return Handle.Name.all; end Unit_Name; ----------------------------- -- Create_Exception_Handle -- ----------------------------- procedure Create_Exception_Handle (Handle : not null Trace_Handle) is S : Trace_Stream; begin if Handle.Exception_Handle = null then -- Unless the config file specified an explicit stream, -- we inherit the one from Handle. if Handle.Stream = Global.Streams_List then S := null; else S := Handle.Stream; end if; Handle.Exception_Handle := Create_Internal (Unit_Name => Handle.Name.all & ".EXCEPTIONS", From_Config_File => False, Stream => S, Default => (if Handle.Active then On else Off), Style => Default_Exception_Style); Cache_Settings (Handle.Exception_Handle); end if; end Create_Exception_Handle; ----------- -- Trace -- ----------- procedure Trace (Handle : not null access Trace_Handle_Record'Class; E : Ada.Exceptions.Exception_Occurrence; Msg : String := "Unexpected exception: "; Color : String) is begin if Debug_Mode then if Handle.With_Colors then Trace (Handle, E, Color & Msg); else Trace (Handle, E, Msg); end if; end if; end Trace; ----------- -- Trace -- ----------- procedure Trace (Handle : not null access Trace_Handle_Record'Class; E : Ada.Exceptions.Exception_Occurrence; Msg : String := "Unexpected exception: "; Style : Message_Style := Use_Default_Style) is begin if Debug_Mode and then not Global.Finalized -- module not terminated then Create_Exception_Handle (Trace_Handle (Handle)); Trace (Handle.Exception_Handle, Msg & Ada.Exceptions.Exception_Information (E), Style => Style); end if; end Trace; ----------- -- Trace -- ----------- procedure Trace (Handle : not null access Trace_Handle_Record'Class; Message : String; Color : String; Location : String := GNAT.Source_Info.Source_Location; Entity : String := GNAT.Source_Info.Enclosing_Entity) is begin if Debug_Mode then if Handle.With_Colors then Trace (Handle, Color & Message, Location => Location, Entity => Entity); else Trace (Handle, Message, Location => Location, Entity => Entity); end if; end if; end Trace; ----------- -- Trace -- ----------- procedure Trace (Handle : not null access Trace_Handle_Record'Class; Message : String; Style : Message_Style := Use_Default_Style; Location : String := GNAT.Source_Info.Source_Location; Entity : String := GNAT.Source_Info.Enclosing_Entity) is -- We want maximum performance for traces. This saves about 2% -- in single-threaded applications and sometimes 1% for multi-threaded -- apps. pragma Suppress (All_Checks); Merged_Style : Message_Style; begin -- Do not output anything until we have called Parse_Config_File, -- and do not output anything after we have called Finalized and -- potentially freed Handle. -- The stream is null if the trace was Create-d as On by default -- but Parse_Config_File was never called. if not Active (Handle) or else Handle.Stream = null then return; end if; declare Start, Last : Natural; Indent : constant Integer := Integer (Handle.Stream.Indentation); With_Color : constant Boolean := Handle.With_Colors; Msg : Msg_Strings.XString; begin for D in 1 .. Global.Active_Last loop Global.Active_Decorators (D).Start_Of_Line (Msg, Is_Continuation => False); end loop; if Indent > 0 then Msg.Append ((1 .. Indent * 3 => ' ')); end if; if With_Color then Merged_Style := Handle.Default_Style; if Style.Fg /= GNATCOLL.Terminal.Unchanged then Merged_Style.Fg := Style.Fg; end if; if Style.Bg /= GNATCOLL.Terminal.Unchanged then Merged_Style.Bg := Style.Bg; end if; if Style.Style /= GNATCOLL.Terminal.Unchanged then Merged_Style.Style := Style.Style; end if; Msg.Append (Cyan_Fg); end if; Msg.Append ('['); Msg.Append (Handle.Name.all); Msg.Append (']'); Msg.Append (' '); -- Decorate before the message for D in 1 .. Global.Active_Last loop Global.Active_Decorators (D).Before_Message (Trace_Handle (Handle), Msg); end loop; -- Add the message if Global.Split_Lines /= null and then Global.Split_Lines.Active then Start := Message'First; loop Last := Start; while Last <= Message'Last and then Message (Last) /= ASCII.LF loop Last := Last + 1; end loop; if With_Color then Msg.Append (GNATCOLL.Terminal.Get_ANSI_Sequence (Merged_Style)); end if; Msg.Append (Message (Start .. Last - 1)); Start := Last + 1; exit when Start > Message'Last; Msg.Append (ASCII.LF); for D in 1 .. Global.Active_Last loop Global.Active_Decorators (D).Start_Of_Line (Msg, Is_Continuation => True); end loop; if Indent > 0 then Msg.Append ((1 .. Indent * 3 => ' ')); end if; if With_Color then Msg.Append (Purple_Fg); end if; Msg.Append ('_'); Msg.Append (Handle.Name.all); Msg.Append ('_'); Msg.Append (' '); end loop; else if With_Color then Msg.Append (GNATCOLL.Terminal.Get_ANSI_Sequence (Merged_Style)); end if; Msg.Append (Message); end if; -- Decorate after the message if Global.Active_Last /= 0 then if With_Color then Msg.Append (Brown_Fg); end if; Msg.Append (' '); for D in 1 .. Global.Active_Last loop Global.Active_Decorators (D).After_Message (Trace_Handle (Handle), Msg); end loop; -- Remove trailing space if needed if Handle.With_Time then Put_Absolute_Time (Msg); end if; if Global.Location.Active then Msg.Append ("(loc: "); Msg.Append (Location); Msg.Append (')'); end if; if Global.Enclosing_Entity.Active then Msg.Append ("(entity:"); Msg.Append (Entity); Msg.Append (')'); end if; Msg.Trim (Ada.Strings.Right); end if; if With_Color then Msg.Append (Reset_All); end if; Msg.Append (ASCII.LF); Handle.Stream.Put (Msg); end; exception when others => case On_Exception is when Propagate => raise; when Ignore => null; when Deactivate => begin Close (Handle.Stream.all); exception when others => null; end; end case; end Trace; ------------ -- Assert -- ------------ procedure Assert (Handle : not null access Trace_Handle_Record'Class; Condition : Boolean; Error_Message : String; Message_If_Success : String := ""; Raise_Exception : Boolean := True; Location : String := GNAT.Source_Info.Source_Location; Entity : String := GNAT.Source_Info.Enclosing_Entity) is begin if Active (Handle) then if not Condition then Create_Exception_Handle (Trace_Handle (Handle)); Trace (Handle.Exception_Handle, Error_Message, Location => Location, Entity => Entity); if Raise_Exception then Raise_Assert_Failure (Error_Message & " (" & Entity & " at " & Location & ")"); end if; elsif Message_If_Success'Length /= 0 then Trace (Handle, Message_If_Success, Location, Entity); end if; end if; end Assert; --------------------- -- Increase_Indent -- --------------------- procedure Increase_Indent (Handle : access Trace_Handle_Record'Class := null; Msg : String := ""; Style : Message_Style := Use_Default_Style; Location : String := GNAT.Source_Info.Source_Location; Entity : String := GNAT.Source_Info.Enclosing_Entity) is begin if Handle /= null and then Handle.Stream /= null then if Msg /= "" then Trace (Handle, Msg, Style, Location => Location, Entity => Entity); end if; if Handle.Active then Increment (Handle.Stream.Indentation); end if; end if; end Increase_Indent; --------------------- -- Decrease_Indent -- --------------------- procedure Decrease_Indent (Handle : access Trace_Handle_Record'Class := null; Msg : String := ""; Style : Message_Style := Use_Default_Style; Location : String := GNAT.Source_Info.Source_Location; Entity : String := GNAT.Source_Info.Enclosing_Entity) is begin if Handle /= null and then Handle.Stream /= null then -- The counter is a modulo type if Handle.Active then if Sync_Sub_And_Fetch (Handle.Stream.Indentation'Unchecked_Access, 1) = Minus_One then Handle.Stream.Indentation := 0; Trace (Handle, "Indentation error: too many decrease"); end if; end if; if Msg /= "" then Trace (Handle, Msg, Style, Location => Location, Entity => Entity); end if; end if; end Decrease_Indent; ---------------------- -- Local_Sub_Second -- ---------------------- function Local_Sub_Second (T : Ada.Calendar.Time) return Integer is Y : Year_Number; M : Month_Number; D : Day_Number; H : Ada.Calendar.Formatting.Hour_Number; Mi : Ada.Calendar.Formatting.Minute_Number; S : Ada.Calendar.Formatting.Second_Number; Ss : Ada.Calendar.Formatting.Second_Duration; Ls : Boolean; begin Ada.Calendar.Formatting.Split (T, Y, M, D, H, Mi, S, Ss, Ls, Global.TZ); if Ss > 0.999 then return 999; else return Integer (Ss * 1000.0); end if; end Local_Sub_Second; ----------------------- -- Put_Absolute_Time -- ----------------------- procedure Put_Absolute_Time (Msg : in out Msg_Strings.XString) is T : constant Ada.Calendar.Time := Ada.Calendar.Clock; Z : String (1 .. 3) := "000"; Ms : constant String := Integer'Image (Local_Sub_Second (T)); begin Z (3 + 1 - (Ms'Length - 1) .. 3) := Ms (Ms'First + 1 .. Ms'Last); if Global.Absolute_Date.Active then if Global.Absolute_Time.Active then if Global.Micro_Time.Active then Msg.Append ("(" & Image (T, ISO_Date & " %T:%e") & ')'); else Msg.Append ("(" & Image (T, ISO_Date & " %T.") & Z & ')'); end if; else Msg.Append ("(" & Image (T, ISO_Date) & ')'); end if; else if Global.Micro_Time.Active then Msg.Append ("(" & Image (T, ISO_Date & " %T:%e") & ')'); else Msg.Append ("(" & Image (T, "%T.") & Z & ')'); end if; end if; end Put_Absolute_Time; -------------------- -- Before_Message -- -------------------- overriding procedure Before_Message (Self : in out Count_Trace; Handle : not null Trace_Handle; Msg : in out Msg_Strings.XString) is -- ??? Should we lock to get consistent counters ? Total : constant Atomic_Counter := Sync_Add_And_Fetch (Self.Count'Unchecked_Access, 1); Local : constant Atomic_Counter := Sync_Add_And_Fetch (Handle.Count'Unchecked_Access, 1); C : constant String := Atomic_Counter'Image (Total); H : constant String := Atomic_Counter'Image (Local); begin Msg.Append (H (H'First + 1 .. H'Last) & '/' & C (C'First + 1 .. C'Last) & ' '); end Before_Message; ------------------- -- After_Message -- ------------------- overriding procedure After_Message (Self : in out Memory_Trace; Handle : not null Trace_Handle; Msg : in out Msg_Strings.XString) is pragma Unreferenced (Handle); use GNATCOLL.Memory; Watermark : constant Watermark_Info := Get_Allocations; begin Msg.Append ("[Watermark:" & (if Watermark.Current > Self.Previous then '>' else '<') & Watermark.Current'Img & '/' & Watermark.High'Img & "]"); Self.Previous := Watermark.Current; end After_Message; ------------------- -- After_Message -- ------------------- overriding procedure After_Message (Self : in out Ada_Memory_Trace; Handle : not null Trace_Handle; Msg : in out Msg_Strings.XString) is pragma Unreferenced (Handle); use GNATCOLL.Memory; Watermark : constant Watermark_Info := Get_Ada_Allocations; begin if Watermark.High /= 0 then Msg.Append ("[AdaWatermark:" & (if Watermark.Current > Self.Previous then '>' else '<') & Watermark.Current'Img & '/' & Watermark.High'Img & "]"); end if; Self.Previous := Watermark.Current; end After_Message; ------------------- -- After_Message -- ------------------- overriding procedure After_Message (Self : in out Elapse_Time_Trace; Handle : not null Trace_Handle; Msg : in out Msg_Strings.XString) is pragma Unreferenced (Self); T : constant Ada.Calendar.Time := Ada.Calendar.Clock; Dur : Integer; begin if Handle.Timer /= No_Time then Dur := Integer ((T - Handle.Timer) * 1000); Msg.Append ("(elapsed:" & Integer'Image (Dur) & "ms)"); end if; Handle.Timer := T; end After_Message; ------------------- -- After_Message -- ------------------- overriding procedure After_Message (Self : in out Stack_Trace; Handle : not null Trace_Handle; Msg : in out Msg_Strings.XString) is pragma Unreferenced (Self, Handle); Tracebacks : GNAT.Traceback.Tracebacks_Array (1 .. 50); Len : Natural; begin Call_Chain (Tracebacks, Len); Msg.Append ("(callstack: "); for J in Tracebacks'First .. Len loop Msg.Append (System.Address_Image (Get_PC (Tracebacks (J))) & ' '); end loop; Msg.Append (")"); end After_Message; -------------------------- -- Add_Global_Decorator -- -------------------------- procedure Add_Global_Decorator (Decorator : not null Trace_Decorator; Name : String) is begin Register_Handle (Trace_Handle (Decorator), To_Upper (Name)); Decorator.Active := False; -- Set this flag, so that a "+" in the config file has no impact on -- decorators. Decorator.Forced_Active := True; end Add_Global_Decorator; ----------------- -- Config_File -- ----------------- function Config_File (Filename : Virtual_File; Default : Virtual_File) return Virtual_File is Env : GNAT.Strings.String_Access; Ret : Virtual_File; begin if Filename /= No_File and then Filename.Is_Regular_File then return Filename; end if; Env := Getenv (Config_File_Environment); -- First test the file described in the environment variable if Env /= null and then Env.all /= "" then Ret := Create (+Env.all); Free (Env); if Ret.Is_Regular_File then return Ret; end if; return No_File; end if; Free (Env); -- Then the file in the current directory Ret := Create_From_Dir (Get_Current_Dir, Default_Config_File); if Ret.Is_Regular_File then return Ret; end if; -- Then the file in the user's home directory Ret := Create_From_Dir (Get_Home_Directory, Default_Config_File); if Ret.Is_Regular_File then return Ret; end if; -- Finally the default file if Default /= No_File and then Is_Regular_File (Default) then return Default; end if; return No_File; end Config_File; ----------------------------- -- Register_Stream_Factory -- ----------------------------- procedure Register_Stream_Factory (Name : String; Factory : Stream_Factory_Access) is begin Lock (Global.Lock); Global.Factories_List := new Stream_Factories' (Name => new String'("&" & Name), Factory => Factory, Next => Global.Factories_List); Unlock (Global.Lock); end Register_Stream_Factory; ----------- -- Close -- ----------- procedure Close (Stream : in out Trace_Stream_Record) is begin Free (Stream.Name); end Close; --------- -- Put -- --------- overriding procedure Put (Stream : in out File_Stream_Record; Str : Msg_Strings.XString) is N : size_t; S : Msg_Strings.Char_Array; L : Natural; begin -- fwrite is thread safe on Windows and POSIX systems, -- we should not need locking. Str.Get_String (S, L); -- The call to fwrite is C, so will not raise exceptions Lock (Stream.Lock); N := fwrite (buffer => S.all'Address, size => size_t (L), count => 1, stream => Stream.File); Unlock (Stream.Lock); if N /= size_t (L) then -- ??? Could not write to file, disk full ? null; end if; end Put; ----------- -- Close -- ----------- overriding procedure Close (Stream : in out File_Stream_Record) is Status : int; pragma Unreferenced (Status); begin if Stream.File /= stdout and then Stream.File /= stderr then Status := fclose (Stream.File); Stream.File := NULL_Stream; end if; GNAT.Strings.Free (Stream.File_Name); Close (Trace_Stream_Record (Stream)); end Close; ------------------ -- Parse_Config -- ------------------ procedure Parse_Config (Config : String; On_Exception : On_Exception_Mode := Propagate; Force_Activation : Boolean := True; Relative_Path_To : GNATCOLL.VFS.Virtual_File := GNATCOLL.VFS.Get_Current_Dir) is Handle : Trace_Handle; Dec : Trace_Decorator; Count : Natural := 0; procedure Create_Decorators; -- Create all default decorators, if not done yet function One_Line (Line : String) return Boolean; -- Callback function for each line of the configuration ----------------------- -- Create_Decorators -- ----------------------- procedure Create_Decorators is begin if Global.Colors = null then Set_Default_Stream ("&1"); Global.Micro_Time := new Trace_Decorator_Record; Add_Global_Decorator (Global.Micro_Time, "DEBUG.MICRO_TIME"); Dec := new Elapse_Time_Trace; Add_Global_Decorator (Dec, "DEBUG.ELAPSED_TIME"); Dec := new Stack_Trace; Add_Global_Decorator (Dec, "DEBUG.STACK_TRACE"); Dec := new Count_Trace; Add_Global_Decorator (Dec, "DEBUG.COUNT"); Dec := new Memory_Trace; Add_Global_Decorator (Dec, "DEBUG.MEMORY"); Dec := new Ada_Memory_Trace; Add_Global_Decorator (Dec, "DEBUG.ADA_MEMORY"); -- These are handled directly in Trace, but we should have them on -- the active list of decorators to know whether we need to add a -- space. Global.Absolute_Time := new Trace_Decorator_Record; Add_Global_Decorator (Global.Absolute_Time, "DEBUG.ABSOLUTE_TIME"); Global.Absolute_Date := new Trace_Decorator_Record; Add_Global_Decorator (Global.Absolute_Date, "DEBUG.ABSOLUTE_DATE"); Global.Enclosing_Entity := new Trace_Decorator_Record; Add_Global_Decorator (Global.Enclosing_Entity, "DEBUG.ENCLOSING_ENTITY"); Global.Location := new Trace_Decorator_Record; Add_Global_Decorator (Global.Location, "DEBUG.LOCATION"); -- The following are not decorators, and handled specially Global.Finalize_Traces := new Trace_Decorator_Record; Add_Global_Decorator (Global.Finalize_Traces, "DEBUG.FINALIZE_TRACES"); Global.Finalize_Traces.Active := True; Global.Split_Lines := new Trace_Decorator_Record; Add_Global_Decorator (Global.Split_Lines, "DEBUG.SPLIT_LINES"); Global.Split_Lines.Active := True; Global.Colors := new Trace_Decorator_Record; Add_Global_Decorator (Global.Colors, "DEBUG.COLORS"); end if; end Create_Decorators; S : constant String := "[ \t]*"; Line_Re : constant GNAT.Regpat.Pattern_Matcher := GNAT.Regpat.Compile ("^(?:" & "([^\s=:>+-]+)" & S -- 1 = name & "(?:=" & S & "(yes|no))?" & S -- 2 = active? & "(:[^\s>]+)?" & S -- 3 = options & "(?:>>?" & S & "(\S+))?" & S -- 4 = stream & "|" & "(>>?\S+)?" & S -- 5 = default stream & "|" & "(\+)" & S -- 6 = "+" & ")?" -- line can be empty & S & "(?:(?:#|--).*)?" -- end of line comments & "\r?$"); function One_Line (Line : String) return Boolean is M : GNAT.Regpat.Match_Array (0 .. 6); Group_Name : constant := 1; Group_Active : constant := 2; Group_Options : constant := 3; Group_Stream : constant := 4; Group_Default_Stream : constant := 5; Group_All : constant := 6; begin Count := Count + 1; if Line = "" then return True; end if; Match (Line_Re, Line, Matches => M); if M (0) = No_Match then if On_Exception = Propagate then raise Constraint_Error with "Line " & Count'Img & ": """ & Line & """ is not recognised."; end if; elsif M (Group_All) /= No_Match then Global.Default_Activation := True; Handle := Global.Handles_List; while Handle /= null loop if not Handle.Forced_Active then Set_Active (Handle, True); -- A later declaration of the stream in the code -- should not be allowed to reset Active to False Handle.Forced_Active := True; end if; Handle := Handle.Next; end loop; elsif M (Group_Default_Stream) /= No_Match then Set_Default_Stream (Config (M (Group_Default_Stream).First .. M (Group_Default_Stream).Last), Config_File => Relative_Path_To); elsif M (Group_Name) /= No_Match then declare Active : constant Default_Activation_Status := (if M (Group_Active) = No_Match or else Config (M (Group_Active).First .. M (Group_Active).Last) /= "no" then On else Off); Stream : Trace_Stream := null; Style : Message_Style := Default_Style; begin -- Do we have options for this handle ? if M (Group_Options) /= No_Match then declare use GNATCOLL.Terminal; Options : String_List_Access := Split (Config (M (Group_Options).First .. M (Group_Options).Last), ':'); begin for Opt of Options.all loop if Starts_With (Opt.all, "fg=") then Style.Fg := ANSI_Color'Value (Opt (Opt'First + 3 .. Opt'Last)); elsif Starts_With (Opt.all, "bg=") then Style.Bg := ANSI_Color'Value (Opt (Opt'First + 3 .. Opt'Last)); elsif Starts_With (Opt.all, "style=") then Style.Style := ANSI_Style'Value (Opt (Opt'First + 6 .. Opt'Last)); end if; end loop; Free (Options); end; end if; -- What stream is this sent to ? if M (Group_Stream) /= No_Match then declare Save : Integer := M (Group_Stream).First; Append : Boolean := False; begin if Save + 1 <= M (Group_Stream).Last and then Config (Save) = '>' then Append := True; Save := Save + 1; end if; Stream := Find_Stream (Config (Save .. M (Group_Stream).Last), Relative_Path_To, Append); end; end if; Handle := Create_Internal (Config (M (Group_Name).First .. M (Group_Name).Last), From_Config_File => True, Default => Active, Style => Style, Stream => Stream); end; end if; return True; end One_Line; begin if not Debug_Mode then return; end if; GNATCOLL.Traces.On_Exception := On_Exception; if Force_Activation or else Config /= "" then Create_Decorators; end if; if Config /= "" then Split (Config, (1 => ASCII.LF), One_Line'Access); end if; end Parse_Config; ----------------------- -- Parse_Config_File -- ----------------------- procedure Parse_Config_File (Filename : Virtual_File; Default : Virtual_File := No_File; On_Exception : On_Exception_Mode := Propagate; Force_Activation : Boolean := True) is File_Name : constant Virtual_File := Config_File (Filename, Default); Buffer : Str_Access; File : Mapped_File; begin if not Debug_Mode then return; end if; GNATCOLL.Traces.On_Exception := On_Exception; if File_Name = No_File then Parse_Config ("", On_Exception, Force_Activation => Force_Activation); else begin File := Open_Read (+File_Name.Full_Name); exception when Ada.IO_Exceptions.Name_Error => Parse_Config ("", On_Exception, Force_Activation => Force_Activation); return; end; Read (File); Buffer := Data (File); Parse_Config (Config => String (Buffer (1 .. Last (File))), On_Exception => On_Exception, Force_Activation => Force_Activation, Relative_Path_To => File_Name.Dir); Close (File); end if; end Parse_Config_File; ----------------------- -- Parse_Config_File -- ----------------------- procedure Parse_Config_File (Filename : String := ""; Default : String := ""; On_Exception : On_Exception_Mode := Propagate; Force_Activation : Boolean := True) is F_Filename : Virtual_File; F_Default : Virtual_File; begin if Filename = "" then F_Filename := No_File; else F_Filename := Create_From_Base (+Filename); end if; if Default = "" then F_Default := No_File; else F_Default := Create_From_Base (+Default); end if; Parse_Config_File (F_Filename, F_Default, On_Exception, Force_Activation); end Parse_Config_File; -------------- -- Finalize -- -------------- procedure Finalize is Tmp : Trace_Handle; Next : Trace_Handle; TmpS : Trace_Stream; NextS : Trace_Stream; TmpF : Stream_Factories_List; NextF : Stream_Factories_List; begin if not Global.Finalized -- Might never have been initialized at all and then Global.Finalize_Traces /= null and then Global.Finalize_Traces.Active then Lock (Global.Lock); Tmp := Global.Handles_List; while Tmp /= null loop Next := Tmp.Next; if Tmp.Finalize then Free (Tmp.Name); Unchecked_Free (Tmp); end if; Tmp := Next; end loop; Global.Handles_List := null; Tmp := Global.Wildcard_Handles_List; while Tmp /= null loop Next := Tmp.Next; if Tmp.Finalize then Free (Tmp.Name); Unchecked_Free (Tmp); end if; Tmp := Next; end loop; Global.Wildcard_Handles_List := null; TmpS := Global.Streams_List; while TmpS /= null loop NextS := TmpS.Next; Close (TmpS.all); Unchecked_Free (TmpS); TmpS := NextS; end loop; Global.Streams_List := null; TmpF := Global.Factories_List; while TmpF /= null loop NextF := TmpF.Next; Free (TmpF.Name); Unchecked_Free (TmpF.Factory); Unchecked_Free (TmpF); TmpF := NextF; end loop; Global.Factories_List := null; Unlock (Global.Lock); end if; Global.Finalized := True; end Finalize; --------------------- -- For_Each_Handle -- --------------------- procedure For_Each_Handle (Proc : not null Handlers_Proc) is Tmp : Trace_Handle := Global.Handles_List; begin while Tmp /= null loop Proc (Tmp); Tmp := Tmp.Next; end loop; end For_Each_Handle; ------------------------ -- Set_Default_Stream -- ------------------------ procedure Set_Default_Stream (Name : String; Config_File : Virtual_File := No_File) is S : Trace_Stream; T : Trace_Stream; H : Trace_Handle; begin if Name'Length > 2 and then Name (Name'First .. Name'First + 1) = ">>" then S := Find_Stream (Name (Name'First + 2 .. Name'Last), Config_File.Dir, Append => True); elsif Name (Name'First) = '>' then S := Find_Stream (Name (Name'First + 1 .. Name'Last), Config_File.Dir, Append => False); else S := Find_Stream (Name, Config_File.Dir, Append => False); end if; if S /= null then -- Put it first in the list Lock (Global.Lock); if Global.Streams_List /= S then T := Global.Streams_List; while T.Next /= S loop T := T.Next; end loop; T.Next := S.Next; S.Next := Global.Streams_List; Global.Streams_List := S; end if; -- Apply the default stream for all streams that do not have an -- explicit one H := Global.Handles_List; while H /= null loop if H.Stream = null or else H.Stream_Is_Default then H.Stream := S; H.Stream_Is_Default := True; Cache_Settings (H); end if; H := H.Next; end loop; Unlock (Global.Lock); end if; end Set_Default_Stream; ----------- -- Count -- ----------- function Count (Handler : not null access Trace_Handle_Record'Class) return Natural is begin return Natural (Handler.Count); end Count; ------------ -- Create -- ------------ function Create (Handle : Trace_Handle; Message : String := ""; Location : String := GNAT.Source_Info.Source_Location; Entity : String := GNAT.Source_Info.Enclosing_Entity; Style : Message_Style := Default_Block_Style) return Block_Trace_Handle is begin return Result : Block_Trace_Handle do if Active (Handle) then Result.Me := Handle; Result.Style := Style; Result.Loc := new String'(Entity & ':' & Location); if Message /= "" then Increase_Indent (Handle, "Entering " & Result.Loc.all & ' ' & Message, Style => Style, Location => "", Entity => ""); else Increase_Indent (Handle, "Entering " & Result.Loc.all, Style => Style, Location => "", Entity => ""); end if; end if; end return; end Create; -------------- -- Finalize -- -------------- overriding procedure Finalize (Self : in out Block_Trace_Handle) is begin -- If we were active when Create was called if Self.Me /= null then Decrease_Indent (Self.Me, "Leaving " & Self.Loc.all, Style => Self.Style, Location => "", -- avoid duplicate info in the output Entity => ""); end if; Free (Self.Loc); end Finalize; end GNATCOLL.Traces;