1------------------------------------------------------------------------------ 2-- -- 3-- Matreshka Project -- 4-- -- 5-- XML Processor -- 6-- -- 7-- Examples Component -- 8-- -- 9------------------------------------------------------------------------------ 10-- -- 11-- Copyright © 2010-2012, 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: 3459 $ $Date: 2012-11-21 11:08:42 +0400 (Wed, 21 Nov 2012) $ 43------------------------------------------------------------------------------ 44with League.IRIs; 45with Put_Line; 46with XML.SAX.Input_Sources.Streams.Files; 47 48package body Events_Printers is 49 50 use type League.Strings.Universal_String; 51 52 function Image (Item : XML.SAX.Locators.SAX_Locator) 53 return League.Strings.Universal_String; 54 55 ---------------- 56 -- Characters -- 57 ---------------- 58 59 overriding procedure Characters 60 (Self : in out Events_Printer; 61 Text : League.Strings.Universal_String; 62 Success : in out Boolean) is 63 begin 64 Put_Line 65 (">>> (Characters) " & Image (Self.Locator) & ": '" & Text & "'"); 66 end Characters; 67 68 ------------- 69 -- Comment -- 70 ------------- 71 72 overriding procedure Comment 73 (Self : in out Events_Printer; 74 Text : League.Strings.Universal_String; 75 Success : in out Boolean) is 76 begin 77 Put_Line (">>> (Comment) " & Image (Self.Locator) & ": '" & Text & "'"); 78 end Comment; 79 80 ----------------- 81 -- End_Element -- 82 ----------------- 83 84 overriding procedure End_Element 85 (Self : in out Events_Printer; 86 Namespace_URI : League.Strings.Universal_String; 87 Local_Name : League.Strings.Universal_String; 88 Qualified_Name : League.Strings.Universal_String; 89 Success : in out Boolean) is 90 begin 91 Put_Line 92 (">>> (End_Element) " 93 & Image (Self.Locator) 94 & ": '" 95 & Namespace_URI 96 & "' '" 97 & Local_Name 98 & "' '" 99 & Qualified_Name 100 & "'"); 101 end End_Element; 102 103 ------------------------ 104 -- End_Prefix_Mapping -- 105 ------------------------ 106 107 overriding procedure End_Prefix_Mapping 108 (Self : in out Events_Printer; 109 Prefix : League.Strings.Universal_String; 110 Success : in out Boolean) is 111 begin 112 Put_Line 113 (">>> (End_Prefix_Mapping) " 114 & Image (Self.Locator) 115 & ": '" 116 & Prefix 117 & "'"); 118 end End_Prefix_Mapping; 119 120 ----------- 121 -- Error -- 122 ----------- 123 124 overriding procedure Error 125 (Self : in out Events_Printer; 126 Occurrence : XML.SAX.Parse_Exceptions.SAX_Parse_Exception; 127 Success : in out Boolean) is 128 begin 129 Put_Line 130 (">>> (Error) " 131 & Image (Self.Locator) 132 & ": '" 133 & Occurrence.Message 134 & "'"); 135 end Error; 136 137 ------------------ 138 -- Error_String -- 139 ------------------ 140 141 overriding function Error_String 142 (Self : Events_Printer) 143 return League.Strings.Universal_String is 144 begin 145 return X : League.Strings.Universal_String; 146 end Error_String; 147 148 --------------------------------- 149 -- External_Entity_Declaration -- 150 --------------------------------- 151 152 overriding procedure External_Entity_Declaration 153 (Self : in out Events_Printer; 154 Name : League.Strings.Universal_String; 155 Public_Id : League.Strings.Universal_String; 156 System_Id : League.Strings.Universal_String; 157 Success : in out Boolean) is 158 begin 159 Put_Line 160 (">>> (External_Entity_Declaration) " 161 & Image (Self.Locator) 162 & ": '" 163 & Name & "' => '" & Public_Id & "' '" & System_Id & "'"); 164 end External_Entity_Declaration; 165 166 ----------------- 167 -- Fatal_Error -- 168 ----------------- 169 170 overriding procedure Fatal_Error 171 (Self : in out Events_Printer; 172 Occurrence : XML.SAX.Parse_Exceptions.SAX_Parse_Exception) is 173 begin 174 Put_Line 175 (">>> (Fatal_Error) " 176 & Image (Self.Locator) 177 & ": '" 178 & Occurrence.Message 179 & "'"); 180 end Fatal_Error; 181 182 -------------------------- 183 -- Ignorable_Whitespace -- 184 -------------------------- 185 186 overriding procedure Ignorable_Whitespace 187 (Self : in out Events_Printer; 188 Text : League.Strings.Universal_String; 189 Success : in out Boolean) is 190 begin 191 Put_Line 192 (">>> (Ignorable_Whitespace) " 193 & Image (Self.Locator) 194 & ": '" 195 & Text 196 & "'"); 197 end Ignorable_Whitespace; 198 199 ----------- 200 -- Image -- 201 ----------- 202 203 function Image (Item : XML.SAX.Locators.SAX_Locator) 204 return League.Strings.Universal_String 205 is 206 L : constant Wide_Wide_String := Natural'Wide_Wide_Image (Item.Line); 207 C : constant Wide_Wide_String := Natural'Wide_Wide_Image (Item.Column); 208 209 begin 210 return 211 League.Strings.To_Universal_String 212 (L (L'First + 1 .. L'Last) 213 & ':' 214 & C (C'First + 1 .. C'Last)); 215 end Image; 216 217 --------------------------------- 218 -- Internal_Entity_Declaration -- 219 --------------------------------- 220 221 overriding procedure Internal_Entity_Declaration 222 (Self : in out Events_Printer; 223 Name : League.Strings.Universal_String; 224 Value : League.Strings.Universal_String; 225 Success : in out Boolean) is 226 begin 227 Put_Line 228 (">>> (Internal_Entity_Declaration) " 229 & Image (Self.Locator) 230 & ": '" 231 & Name 232 & "' => '" 233 & Value 234 & "'"); 235 end Internal_Entity_Declaration; 236 237 ---------------------------- 238 -- Processing_Instruction -- 239 ---------------------------- 240 241 overriding procedure Processing_Instruction 242 (Self : in out Events_Printer; 243 Target : League.Strings.Universal_String; 244 Data : League.Strings.Universal_String; 245 Success : in out Boolean) is 246 begin 247 Put_Line 248 (">>> (Processing_Instruction) " 249 & Image (Self.Locator) 250 & ": '" 251 & Target 252 & "' '" 253 & Data 254 & "'"); 255 end Processing_Instruction; 256 257 -------------------- 258 -- Resolve_Entity -- 259 -------------------- 260 261 overriding procedure Resolve_Entity 262 (Self : in out Events_Printer; 263 Name : League.Strings.Universal_String; 264 Public_Id : League.Strings.Universal_String; 265 Base_URI : League.Strings.Universal_String; 266 System_Id : League.Strings.Universal_String; 267 Source : out XML.SAX.Input_Sources.SAX_Input_Source_Access; 268 Success : in out Boolean) 269 is 270 use XML.SAX.Input_Sources.Streams.Files; 271 272 begin 273 Source := new File_Input_Source; 274 File_Input_Source'Class (Source.all).Open_By_URI 275 (League.IRIs.From_Universal_String (Base_URI).Resolve 276 (League.IRIs.From_Universal_String (System_Id)).To_Universal_String); 277 end Resolve_Entity; 278 279 -------------------------- 280 -- Set_Document_Locator -- 281 -------------------------- 282 283 overriding procedure Set_Document_Locator 284 (Self : in out Events_Printer; 285 Locator : XML.SAX.Locators.SAX_Locator) is 286 begin 287 Self.Locator := Locator; 288 end Set_Document_Locator; 289 290 ------------------- 291 -- Start_Element -- 292 ------------------- 293 294 overriding procedure Start_Element 295 (Self : in out Events_Printer; 296 Namespace_URI : League.Strings.Universal_String; 297 Local_Name : League.Strings.Universal_String; 298 Qualified_Name : League.Strings.Universal_String; 299 Attributes : XML.SAX.Attributes.SAX_Attributes; 300 Success : in out Boolean) is 301 begin 302 Put_Line 303 (">>> (Start_Element) " 304 & Image (Self.Locator) 305 & ": '" 306 & Namespace_URI 307 & "' '" 308 & Local_Name 309 & "' '" 310 & Qualified_Name 311 & "'"); 312 313 for J in 1 .. Attributes.Length loop 314 Put_Line 315 (" '" & Attributes.Namespace_URI (J) 316 & "' '" & Attributes.Local_Name (J) 317 & "' '" & Attributes.Qualified_Name (J) 318 & "' '" & Attributes.Value (J) & "'"); 319 end loop; 320 end Start_Element; 321 322 -------------------------- 323 -- Start_Prefix_Mapping -- 324 -------------------------- 325 326 overriding procedure Start_Prefix_Mapping 327 (Self : in out Events_Printer; 328 Prefix : League.Strings.Universal_String; 329 Namespace_URI : League.Strings.Universal_String; 330 Success : in out Boolean) is 331 begin 332 Put_Line 333 (">>> (Start_Prefix_Mapping) " 334 & Image (Self.Locator) 335 & ": '" 336 & Prefix 337 & "' => '" 338 & Namespace_URI 339 & "'"); 340 end Start_Prefix_Mapping; 341 342 --------------------------------- 343 -- Unparsed_Entity_Declaration -- 344 --------------------------------- 345 346 overriding procedure Unparsed_Entity_Declaration 347 (Self : in out Events_Printer; 348 Name : League.Strings.Universal_String; 349 Public_Id : League.Strings.Universal_String; 350 System_Id : League.Strings.Universal_String; 351 Notation_Name : League.Strings.Universal_String; 352 Success : in out Boolean) is 353 begin 354 Put_Line 355 (">>> (Unparsed_Entity_Declaration) " 356 & Image (Self.Locator) 357 & ": '" 358 & Name 359 & "' => '" 360 & Public_Id 361 & "' '" 362 & System_Id 363 & "' '" 364 & Notation_Name 365 & "'"); 366 end Unparsed_Entity_Declaration; 367 368 ------------- 369 -- Warning -- 370 ------------- 371 372 overriding procedure Warning 373 (Self : in out Events_Printer; 374 Occurrence : XML.SAX.Parse_Exceptions.SAX_Parse_Exception; 375 Success : in out Boolean) is 376 begin 377 Put_Line 378 (">>> (Warning) " 379 & Image (Self.Locator) 380 & ": '" 381 & Occurrence.Message 382 & "'"); 383 end Warning; 384 385end Events_Printers; 386