1------------------------------------------------------------------------------ 2-- -- 3-- Matreshka Project -- 4-- -- 5-- XML Processor -- 6-- -- 7-- Runtime Library Component -- 8-- -- 9------------------------------------------------------------------------------ 10-- -- 11-- Copyright © 2010-2014, Vadim Godunko <vgodunko@gmail.com> -- 12-- All rights reserved. -- 13-- -- 14-- Redistribution and use in source and binary forms, with or without -- 15-- modification, are permitted provided that the following conditions -- 16-- are met: -- 17-- -- 18-- * Redistributions of source code must retain the above copyright -- 19-- notice, this list of conditions and the following disclaimer. -- 20-- -- 21-- * Redistributions in binary form must reproduce the above copyright -- 22-- notice, this list of conditions and the following disclaimer in the -- 23-- documentation and/or other materials provided with the distribution. -- 24-- -- 25-- * Neither the name of the Vadim Godunko, IE nor the names of its -- 26-- contributors may be used to endorse or promote products derived from -- 27-- this software without specific prior written permission. -- 28-- -- 29-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -- 30-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -- 31-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -- 32-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -- 33-- HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -- 34-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED -- 35-- TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -- 36-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -- 37-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -- 38-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- 39-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- 40-- -- 41------------------------------------------------------------------------------ 42-- $Revision: 4789 $ $Date: 2014-03-31 10:02:27 +0400 (Mon, 31 Mar 2014) $ 43------------------------------------------------------------------------------ 44private with Ada.Containers.Hashed_Maps; 45private with Ada.Containers.Ordered_Maps; 46private with Ada.Containers.Vectors; 47 48with League.Characters; 49with League.Strings.Hash; 50with XML.SAX.Attributes; 51with XML.SAX.Output_Destinations; 52with XML.SAX.Writers; 53 54package XML.SAX.Pretty_Writers is 55 56 type SAX_Output_Destination_Access is 57 access all XML.SAX.Output_Destinations.SAX_Output_Destination'Class; 58 59 type XML_Version is (XML_1_0, XML_1_1); 60 61 type XML_Pretty_Writer is limited new XML.SAX.Writers.SAX_Writer with private; 62 63 not overriding procedure Set_Version 64 (Self : in out XML_Pretty_Writer; 65 Version : XML_Version); 66 67 not overriding procedure Set_Offset 68 (Self : in out XML_Pretty_Writer; 69 Offset : Natural); 70 -- Sets offset for indentation. 71 72 not overriding procedure Set_Value_Delimiter 73 (Self : in out XML_Pretty_Writer; 74 Delimiter : League.Characters.Universal_Character); 75 -- Sets value delimiter for attributes. 76 -- '"' (apostrophe) is used by default 77 78 procedure Set_Output_Destination 79 (Self : in out XML_Pretty_Writer'Class; 80 Output : not null SAX_Output_Destination_Access); 81 -- Sets output destination to be used to output generated stream. 82 83 overriding procedure Characters 84 (Self : in out XML_Pretty_Writer; 85 Text : League.Strings.Universal_String; 86 Success : in out Boolean); 87 88 overriding procedure Comment 89 (Self : in out XML_Pretty_Writer; 90 Text : League.Strings.Universal_String; 91 Success : in out Boolean); 92 93 overriding procedure End_CDATA 94 (Self : in out XML_Pretty_Writer; 95 Success : in out Boolean); 96 97 overriding procedure End_Document 98 (Self : in out XML_Pretty_Writer; 99 Success : in out Boolean); 100 101 overriding procedure End_DTD 102 (Self : in out XML_Pretty_Writer; 103 Success : in out Boolean); 104 105 overriding procedure End_Element 106 (Self : in out XML_Pretty_Writer; 107 Namespace_URI : League.Strings.Universal_String; 108 Local_Name : League.Strings.Universal_String; 109 Qualified_Name : League.Strings.Universal_String; 110 Success : in out Boolean); 111 112 overriding procedure End_Entity 113 (Self : in out XML_Pretty_Writer; 114 Name : League.Strings.Universal_String; 115 Success : in out Boolean); 116 117 overriding procedure End_Prefix_Mapping 118 (Self : in out XML_Pretty_Writer; 119 Prefix : League.Strings.Universal_String 120 := League.Strings.Empty_Universal_String; 121 Success : in out Boolean); 122 123 overriding function Error_String 124 (Self : XML_Pretty_Writer) return League.Strings.Universal_String; 125 126 overriding procedure Ignorable_Whitespace 127 (Self : in out XML_Pretty_Writer; 128 Text : League.Strings.Universal_String; 129 Success : in out Boolean); 130 131 overriding procedure Processing_Instruction 132 (Self : in out XML_Pretty_Writer; 133 Target : League.Strings.Universal_String; 134 Data : League.Strings.Universal_String; 135 Success : in out Boolean); 136 137 overriding procedure Skipped_Entity 138 (Self : in out XML_Pretty_Writer; 139 Name : League.Strings.Universal_String; 140 Success : in out Boolean); 141 142 overriding procedure Start_CDATA 143 (Self : in out XML_Pretty_Writer; 144 Success : in out Boolean); 145 146 overriding procedure Start_Document 147 (Self : in out XML_Pretty_Writer; 148 Success : in out Boolean); 149 150 overriding procedure Start_DTD 151 (Self : in out XML_Pretty_Writer; 152 Name : League.Strings.Universal_String; 153 Public_Id : League.Strings.Universal_String; 154 System_Id : League.Strings.Universal_String; 155 Success : in out Boolean); 156 157 overriding procedure Start_Element 158 (Self : in out XML_Pretty_Writer; 159 Namespace_URI : League.Strings.Universal_String; 160 Local_Name : League.Strings.Universal_String; 161 Qualified_Name : League.Strings.Universal_String; 162 Attributes : XML.SAX.Attributes.SAX_Attributes; 163 Success : in out Boolean); 164 165 overriding procedure Start_Entity 166 (Self : in out XML_Pretty_Writer; 167 Name : League.Strings.Universal_String; 168 Success : in out Boolean); 169 170 overriding procedure Start_Prefix_Mapping 171 (Self : in out XML_Pretty_Writer; 172 Prefix : League.Strings.Universal_String 173 := League.Strings.Empty_Universal_String; 174 Namespace_URI : League.Strings.Universal_String; 175 Success : in out Boolean); 176 177private 178 179 package Mappings is 180 new Ada.Containers.Hashed_Maps 181 (League.Strings.Universal_String, 182 League.Strings.Universal_String, 183 League.Strings.Hash, 184 League.Strings."=", 185 League.Strings."="); 186 187 package Banks is 188 new Ada.Containers.Ordered_Maps 189 (League.Strings.Universal_String, 190 League.Strings.Universal_String, 191 League.Strings."<", 192 League.Strings."="); 193 194 type Element_Record is record 195 Namespace_URI : League.Strings.Universal_String; 196 Local_Name : League.Strings.Universal_String; 197 Qualified_Name : League.Strings.Universal_String; 198 Mapping : Mappings.Map; 199 end record; 200 201 package Element_Vector is 202 new Ada.Containers.Vectors (Natural, Element_Record); 203 204 procedure Merge (Current : in out Mappings.Map; Bank : Banks.Map); 205 -- Merges namespaces declared for current element into the set of all 206 -- namespaces. 207 208 type XML_Pretty_Writer is limited new XML.SAX.Writers.SAX_Writer with record 209 Nesting : Natural := 0; 210 Version : XML_Version := XML_1_0; 211 Tag_Opened : Boolean := False; 212 DTD_Opened : Boolean := False; 213 Error : League.Strings.Universal_String; 214 Destination : SAX_Output_Destination_Access; 215 216 Indent : Natural := 0; 217 Offset : Natural := 0; 218 Chars : Boolean := False; 219 -- Indent, offset and chars are used for automatic indentation. 220 221 Stack : Element_Vector.Vector; 222 -- Stack of elements. 223 224 Requested_NS : Banks.Map; 225 -- Set of namespace mappings requested for the next element. 226 227 Current : Element_Record; 228 -- Current processing element including effective namespace mapping. 229 230 Delimiter : League.Characters.Universal_Character 231 := League.Characters.To_Universal_Character ('''); 232 -- Delimiter for atribute='value'. 233 end record; 234 235 function Escape 236 (Self : XML_Pretty_Writer; 237 Text : League.Strings.Universal_String; 238 Escape_All : Boolean := False) 239 return League.Strings.Universal_String; 240 -- Replaces special characters by their entity references. 241 242end XML.SAX.Pretty_Writers; 243