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