File : adagio-trace.adb
------------------------------------------------------------------------------
-- ADAGIO - ADALID - AENEA. --
-- --
-- Copyright (C) 2003 --
-- A. Mosteo. --
-- --
-- Authors: A. Mosteo. (adagio@mosteo.com) --
-- --
-- If you have any questions in regard to this software, please address --
-- them to the above email. --
-- --
-- This program 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 program 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. --
-- --
-- You are not allowed to use any part of this code to develop a program --
-- whose output would be used to harass or prosecute other users of the --
-- networks Adagio connects with. All data collected with Adagio or a tool --
-- containing Adagio code about other network users must remain --
-- confidential and cannot be made public by any mean, nor be used to --
-- harass or legally prosecute these users. --
------------------------------------------------------------------------------
-- $Id: adagio-trace.adb,v 1.5 2004/02/05 18:31:21 Jano Exp $
-- Package for help in tracing events
with Adagio.Debug;
with Adagio.Event_log;
with Adagio.Globals.Options;
with Adagio.Misc;
with Adagio.OS;
with Gnat.Os_lib; use Gnat;
with Text_io; use Text_io;
with Ada.Calendar; use Ada.Calendar;
with System;
with Pragmarc.Assignment;
with Pragmarc.Queue_bounded_blocking;
package body Adagio.Trace is
-- Minimum debug level
-- See elaboration for additional initializing.
Minimum_Level : Warning_Level := Warning_level'Value (
S (Globals.Options.Debug_loglevel));
procedure Check_changed_level is
begin
Minimum_Level := Warning_level'Value (
S (Globals.Options.Debug_loglevel));
end Check_changed_level;
task Poll_task is
pragma Priority (System.Default_Priority + 1);
end Poll_task;
-- Instance vars for debugging.
-- To avoid continuous polling in the tracing function:
Debug_on : boolean renames Globals.Options.Debug_active;
Logfile : Ustring renames Globals.Options.Debug_logfile;
Echo : Boolean renames Globals.Options.Debug_ConsoleEcho;
---
type A_trace is record
Text : Ustring;
File : Ustring;
end record;
procedure Assign is new Pragmarc.Assignment (A_trace);
package Trace_queue is new Pragmarc.Queue_bounded_blocking (
A_trace, Assign);
Queue : Trace_queue.Handle (1000, System.Priority'Last);
Queue_out : Trace_queue.Handle (1000, System.Priority'Last);
-----------------
-- Poll_task
-----------------
task body Poll_task is
No_File : constant Ustring := U ("");
Next : A_trace;
Real_file : Ustring;
F : Text_io.File_type;
Last : Calendar.Time;
Current_File : Ustring := No_File;
use type Calendar.Time;
begin
loop
begin
select
Queue.Get (Next);
if not Queue_out.Full then
select
Queue_out.Put (Next);
or
delay 0.01;
end select;
end if;
Last := Calendar.Clock;
-- Write next:
if Next.File = "" then
Real_file:= Logfile;
else
Real_file:= Next.File;
end if;
if Real_file /= "error" then
begin
if Real_File /= Current_File then
if Current_File /= No_File then
Text_IO.Close (F);
end if;
Current_File := Real_File;
if Gnat.Os_lib.Is_regular_file (S (Real_file)) then
Text_io.Open(f,
Mode => Text_io.Append_file,
Name => S (Real_file));
else
Text_io.Create(f,
Mode => Text_io.Out_file,
Name => S (Real_file));
end if;
end if;
Text_IO.Put_line (f, S (Next.Text));
Text_IO.Flush (F);
exception
when others =>
if Text_io.Is_open (f) then
Text_io.Close (f);
Current_file := No_file;
raise;
end if;
end;
end if;
or
delay until Clock + 1.0;
end select;
exception
when E : others =>
Os.Message_box ("Trace.Poll_task", Trace.Report (E));
end;
exit when
Globals.Requested_exit and then
Queue.Empty and then
Calendar.Clock - Last > 5.0;
end loop;
Adagio.Debug.Tracing_finished := true;
end Poll_task;
subtype Warn_Prefix is String (1 .. 4);
type Prefix is array (All_levels) of Warn_Prefix;
Warn : constant Prefix := (
Never => ":n: ",
Debug => "-d- ",
Informative => "(i) ",
Error => "[E] ",
Warning => "<w> ",
Always => "!A! ");
Event_equiv : constant array (All_levels) of Event_log.Levels := (
Never => Event_log.Debug,
Debug => Event_log.Debug,
Informative => Event_log.Normal,
Error => Event_log.Error,
Warning => Event_log.Warning,
Always => Event_log.Normal);
-- Logs a text to log file. Slow, thread safe.
-- Timestamp automatically prepended.
procedure Log(
Text : String;
Warning : All_levels := Debug;
File : String := "")
is
Next : A_trace;
begin
if not Debug_on then -- Earliest exit
return;
elsif Warning < Minimum_level then
return;
-- elsif Globals.Requested_exit then
-- return;
end if;
Next.Text :=
U ("[" & Adagio.Misc.Timestamp & "] " & Warn (Warning) & Text);
Next.File := U (File);
if Echo then
begin
Put_line (S (Next.Text));
exception
when others =>
null;
end;
end if;
-- To web log
Event_log.Add ((
Arrival => Calendar.Clock,
Level => Event_equiv (Warning),
Text => U (Text)));
-- Exit if finished
if Adagio.Debug.Tracing_Finished then
return;
end if;
select
Queue.Put (Next);
or
delay until Clock + 1.0;
end select;
exception
when E : others =>
Os.Message_box ("Trace.Log", Exception_information (E));
end Log;
-- Displays a box with info about some exception
procedure Report(e: Ada.Exceptions.Exception_occurrence;
Context: String:= "") is
begin
OS.Message_box
("Adagio " & Context,
"Error: " & Ada.Exceptions.Exception_name(e) & ": " &
Ada.Exceptions.Exception_message(e));
end Report;
-- Constructs a error string upon exception:
function Report(e: Ada.Exceptions.Exception_occurrence) return String is
begin
-- return Ada.Exceptions.Exception_name(e) & ": " &
-- Ada.Exceptions.Exception_message(e) &
return Exception_information (e);
end Report;
-- Returns next N characters from a stream as hex
function Debug_stream (
Stream : access Streams.Root_stream_type'Class;
N : Positive := 8;
Separator : String := ":") return String is
S : String (1 .. N);
R : UString;
begin
String'Read (Stream, S);
for n in S'Range loop
R := R & "0x" & Misc.To_hex (S (n));
if n /= S'Last then
R := R & Separator;
end if;
end loop;
return To_string (R);
end Debug_stream;
-- Get pending logs
function Get_logs return Ustring_array is
Result : Ustring_array (1 .. 10);
Pos : Natural := 0;
Next : A_trace;
begin
while Pos < Result'Last and not Queue_out.Empty loop
Pos := Pos + 1;
Queue_out.Get (Next);
Result (Pos) := Next.Text;
end loop;
return Result (1 .. Pos);
end Get_logs;
end Adagio.Trace;