-- -- -- package Copyright (c) Dmitry A. Kazakov -- -- Gtk.Main.Router.GNAT_Stack Luebeck -- -- Implementation Autumn, 2007 -- -- -- -- Last revision : 21:19 26 Jan 2018 -- -- -- -- This library is free software; you can redistribute it and/or -- -- modify it under the terms of the GNU General Public License as -- -- published by the Free Software Foundation; either version 2 of -- -- the License, 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 -- -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- -- General Public License for more details. You should have -- -- received a copy of the GNU General Public License along with -- -- this library; if not, write to the Free Software Foundation, -- -- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -- -- -- -- As a special exception, if other files instantiate generics from -- -- this unit, or you link this unit with other files to produce an -- -- executable, this unit does not by itself cause the resulting -- -- executable to be covered by the GNU General Public License. This -- -- exception does not however invalidate any other reasons why the -- -- executable file might be covered by the GNU Public License. -- --____________________________________________________________________-- with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; with Ada.Strings.Fixed; use Ada.Strings.Fixed; with GNAT.Traceback; use GNAT.Traceback; with GNAT.Traceback.Symbolic; use GNAT.Traceback.Symbolic; with Interfaces.C.Strings; use Interfaces.C.Strings; with System; use System; with Ada.Text_IO; with GNAT.Most_Recent_Exception; package body Gtk.Main.Router.GNAT_Stack is Traceback_Depth : constant := 1_000; Filters_List : Log_Filter_Ptr; procedure Dump_Call_Stack (Prefix : String := "") is use Ada.Text_IO, GNAT.Most_Recent_Exception; TB : Tracebacks_Array (1..Traceback_Depth); Len : Natural; begin Call_Chain (TB, Len); if Prefix'Length > 0 then Put_Line (Prefix); end if; Put_Line (Symbolic_Traceback (TB (1..Len))); if Occurrence_Access /= null then Put_Line ( "Most recent exception: " & Exception_Information (Occurrence_Access.all) ); end if; end Dump_Call_Stack; procedure Finalize (Filter : in out Log_Filter) is begin if Filter.Next /= null then if Filters_List = Filter'Unchecked_Access then if Filter.Next = Filter'Unchecked_Access then Filters_List := null; else Filters_List := Filter.Next; Filter.Previous.Next := Filter.Next; Filter.Next.Previous := Filter.Previous; end if; else Filter.Previous.Next := Filter.Next; Filter.Next.Previous := Filter.Previous; end if; Filter.Next := null; end if; end Finalize; procedure Indent ( Message : UTF8_String; Break : Boolean := Standard.False; Step : Positive := 2 ) is TB : Tracebacks_Array (1..Traceback_Depth); Len : Natural; begin Call_Chain (TB, Len); Len := Integer'Max (0, Len - 1) * Step; Gtk.Main.Router.Trace ( Message => Len * ' ' & Message, Break => Break ); end Indent; procedure Initialize (Filter : in out Log_Filter) is begin if Filters_List = null then Filters_List := Filter'Unchecked_Access; Filter.Previous := Filters_List; Filter.Next := Filters_List; else Filter.Previous := Filters_List.Previous; Filter.Next := Filters_List; Filters_List.Previous := Filter'Unchecked_Access; Filters_List.Previous.Next := Filter'Unchecked_Access; end if; end Initialize; procedure Say ( Message : UTF8_String; Title : UTF8_String := ""; Mode : UTF8_String := Stock_Dialog_Info; Justification : Gtk_Justification := Justify_Left; Parent : access Gtk_Widget_Record'Class := null ) is TB : Tracebacks_Array (1..Traceback_Depth); Len : Natural; begin Call_Chain (TB, Len); Gtk.Main.Router.Say ( Message => Message & LF & Symbolic_Traceback (TB (1..Len)), Title => Title, Mode => Mode, Parent => Parent, Justification => Justification ); end Say; procedure Trace ( Message : UTF8_String; Break : Boolean := Standard.False ) is TB : Tracebacks_Array (1..Traceback_Depth); Len : Natural; begin Call_Chain (TB, Len); Gtk.Main.Router.Trace ( Message => Message & LF & Symbolic_Traceback (TB (1..Len)), Break => Break ); end Trace; procedure Trace ( Error : Exception_Occurrence; Break : Boolean := Standard.True ) is begin Gtk.Main.Router.Trace ( Message => ( Exception_Information (Error) & LF & Symbolic_Traceback (Error) ), Break => Break ); end Trace; type Log_Function_Ptr is access procedure ( Domain : String; Level : Log_Level_Flags; Message : UTF8_String ); procedure Log_Function ( Domain : String; Level : Log_Level_Flags; Message : UTF8_String ) is Head : constant Log_Filter_Ptr := Filters_List; begin if Head /= null then declare This : Log_Filter_Ptr := Head; Next : Log_Filter_Ptr; Done : Boolean; begin loop Next := This.Next; Done := Next = Head; if This.Ignore (Domain, Level, Message) then return; end if; exit when Done; This := Next; end loop; end; end if; declare TB : Tracebacks_Array (1..Traceback_Depth); Len : Natural; begin Call_Chain (TB, Len); Log_Default_Handler (Domain, Level, Message); if Is_Active then Gtk.Main.Router.Trace ( Message => ( Domain & " " & Message & LF & Symbolic_Traceback (TB (1..Len)) ), Break => Standard.True ); else -- Dump to the output instead Ada.Text_IO.Put_Line (Domain & " " & Message); Ada.Text_IO.Put_Line (Symbolic_Traceback (TB (1..Len))); end if; end; end Log_Function; procedure Set_Log_Trace ( Domain : String; Level : Log_Level_Flags := Log_Fatal_Mask or Log_Level_Critical ) is ID : Log_Handler_ID; begin ID := Log_Set_Handler (Domain, Level, Log_Function'Access); end Set_Log_Trace; type Log_Func_Ptr is access procedure ( Domain : Chars_Ptr; Level : Log_Level_Flags; Message : chars_ptr; Handler : Log_Function_Ptr ); pragma Convention (C, Log_Func_Ptr); procedure Log_Func ( Domain : Chars_Ptr; Level : Log_Level_Flags; Message : chars_ptr; Handler : Log_Function_Ptr ); pragma Convention (C, Log_Func); procedure Log_Func ( Domain : chars_ptr; Level : Log_Level_Flags; Message : chars_ptr; Handler : Log_Function_Ptr ) is begin if Domain = Null_Ptr then Handler ("", Level, Value (Message)); else Handler (Value (Domain), Level, Value (Message)); end if; exception when others => null; end Log_Func; procedure Set_Log_Trace is function Internal ( Func : Log_Func_Ptr := Log_Func'Access; Data : Address := Log_Function'Address ) return Log_Handler_ID; pragma Import (C, Internal, "g_log_set_default_handler"); ID : Log_Handler_ID; begin ID := Internal; end Set_Log_Trace; end Gtk.Main.Router.GNAT_Stack;