1------------------------------------------------------------------------------
2--                     XML/Ada - An XML suite for Ada95                     --
3--                                                                          --
4--                     Copyright (C) 2004-2017, AdaCore                     --
5--                                                                          --
6-- This library is free software;  you can redistribute it and/or modify it --
7-- under terms of the  GNU General Public License  as published by the Free --
8-- Software  Foundation;  either version 3,  or (at your  option) any later --
9-- version. This library is distributed in the hope that it will be useful, --
10-- but WITHOUT ANY WARRANTY;  without even the implied warranty of MERCHAN- --
11-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.                            --
12--                                                                          --
13-- As a special exception under Section 7 of GPL version 3, you are granted --
14-- additional permissions described in the GCC Runtime Library Exception,   --
15-- version 3.1, as published by the Free Software Foundation.               --
16--                                                                          --
17-- You should have received a copy of the GNU General Public License and    --
18-- a copy of the GCC Runtime Library Exception along with this program;     --
19-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
20-- <http://www.gnu.org/licenses/>.                                          --
21--                                                                          --
22------------------------------------------------------------------------------
23
24with Ada.Text_IO;  use Ada.Text_IO;
25
26package body Schema is
27
28   Debug_Prefixes_Level : Natural := 0;
29
30   ------------------
31   -- Debug_Output --
32   ------------------
33
34   procedure Debug_Output
35     (Str  : String;
36      Mode : Debug_Output_Mode := Debug_Default) is
37   begin
38      Put ((1 .. Debug_Prefixes_Level * 2 => ' '));
39
40      case Mode is
41         when Debug_Default =>
42            null;
43         when Debug_Seen =>
44            Put (ASCII.ESC & "[33m");
45         when Debug_Action =>
46            Put (ASCII.ESC & "[34m");
47      end case;
48
49      Put (Str);
50
51      if Mode /= Debug_Default then
52         Put (ASCII.ESC & "[39m");
53      end if;
54
55      New_Line;
56   end Debug_Output;
57
58   -------------------
59   -- Output_Action --
60   -------------------
61
62   procedure Output_Action (Str : String) is
63   begin
64      Debug_Output (Str, Mode => Debug_Action);
65   end Output_Action;
66
67   -----------------
68   -- Output_Seen --
69   -----------------
70
71   procedure Output_Seen (Str : String) is
72   begin
73      Debug_Output (Str, Mode => Debug_Seen);
74   end Output_Seen;
75
76   ----------------------
77   -- Set_Debug_Output --
78   ----------------------
79
80   procedure Set_Debug_Output (Output : Boolean) is
81   begin
82      Debug := Output;
83   end Set_Debug_Output;
84
85   -----------------------
86   -- Debug_Push_Prefix --
87   -----------------------
88
89   procedure Debug_Push_Prefix
90     (Append : String; Mode : Debug_Output_Mode := Debug_Default)
91   is
92   begin
93      if Debug then
94         Debug_Output (Append, Mode);
95         Debug_Prefixes_Level := Debug_Prefixes_Level + 1;
96      end if;
97   end Debug_Push_Prefix;
98
99   ----------------------
100   -- Debug_Pop_Prefix --
101   ----------------------
102
103   procedure Debug_Pop_Prefix is
104   begin
105      if Debug then
106         Debug_Prefixes_Level := Debug_Prefixes_Level - 1;
107      end if;
108   end Debug_Pop_Prefix;
109
110   --------------------
111   -- Debug_Tag_Name --
112   --------------------
113
114   function Debug_Tag_Name (Self : Ada.Tags.Tag) return String is
115      E : constant String := Ada.Tags.External_Tag (Self);
116   begin
117      for P in reverse E'Range loop
118         if E (P) = '.' then
119            return E (P + 1 .. E'Last);
120         end if;
121      end loop;
122
123      return E;
124   end Debug_Tag_Name;
125
126end Schema;
127