1----------------------------------------------------------------------- 2-- util-serialize-io-xml -- XML Serialization Driver 3-- Copyright (C) 2011, 2012, 2013 Stephane Carrez 4-- Written by Stephane Carrez (Stephane.Carrez@gmail.com) 5-- 6-- Licensed under the Apache License, Version 2.0 (the "License"); 7-- you may not use this file except in compliance with the License. 8-- You may obtain a copy of the License at 9-- 10-- http://www.apache.org/licenses/LICENSE-2.0 11-- 12-- Unless required by applicable law or agreed to in writing, software 13-- distributed under the License is distributed on an "AS IS" BASIS, 14-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 15-- See the License for the specific language governing permissions and 16-- limitations under the License. 17----------------------------------------------------------------------- 18 19with Unicode; 20with Unicode.CES.Utf8; 21 22with Util.Log.Loggers; 23with Util.Strings; 24package body Util.Serialize.IO.XML is 25 26 use Sax.Readers; 27 use Sax.Exceptions; 28 use Sax.Locators; 29 use Sax.Attributes; 30 use Unicode; 31 use Unicode.CES; 32 use Ada.Strings.Unbounded; 33 34 -- The logger 35 Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Util.Serialize.IO.XML", Util.Log.ERROR_LEVEL); 36 37 -- Return the location where the exception was raised. 38 function Get_Location (Except : Sax.Exceptions.Sax_Parse_Exception'Class) 39 return String is separate; 40 41 -- ------------------------------ 42 -- Warning 43 -- ------------------------------ 44 overriding 45 procedure Warning (Handler : in out Xhtml_Reader; 46 Except : Sax.Exceptions.Sax_Parse_Exception'Class) is 47 pragma Warnings (Off, Handler); 48 begin 49 Log.Warn ("{0}", Get_Message (Except)); 50 end Warning; 51 52 -- ------------------------------ 53 -- Error 54 -- ------------------------------ 55 overriding 56 procedure Error (Handler : in out Xhtml_Reader; 57 Except : in Sax.Exceptions.Sax_Parse_Exception'Class) is 58 Msg : constant String := Get_Message (Except); 59 Pos : constant Natural := Util.Strings.Index (Msg, ' '); 60 begin 61 -- The SAX error message contains the line+file name. Remove it because this part 62 -- will be added by the <b>Error</b> procedure. 63 if Pos > Msg'First and then Msg (Pos - 1) = ':' then 64 Handler.Handler.Error (Msg (Pos + 1 .. Msg'Last)); 65 else 66 Handler.Handler.Error (Msg); 67 end if; 68 end Error; 69 70 -- ------------------------------ 71 -- Fatal_Error 72 -- ------------------------------ 73 overriding 74 procedure Fatal_Error (Handler : in out Xhtml_Reader; 75 Except : in Sax.Exceptions.Sax_Parse_Exception'Class) is 76 begin 77 Handler.Error (Except); 78 end Fatal_Error; 79 80 -- ------------------------------ 81 -- Set_Document_Locator 82 -- ------------------------------ 83 overriding 84 procedure Set_Document_Locator (Handler : in out Xhtml_Reader; 85 Loc : in out Sax.Locators.Locator) is 86 begin 87 Handler.Handler.Locator := Loc; 88 end Set_Document_Locator; 89 90 -- ------------------------------ 91 -- Start_Document 92 -- ------------------------------ 93 overriding 94 procedure Start_Document (Handler : in out Xhtml_Reader) is 95 begin 96 null; 97 end Start_Document; 98 99 -- ------------------------------ 100 -- End_Document 101 -- ------------------------------ 102 overriding 103 procedure End_Document (Handler : in out Xhtml_Reader) is 104 begin 105 null; 106 end End_Document; 107 108 -- ------------------------------ 109 -- Start_Prefix_Mapping 110 -- ------------------------------ 111 overriding 112 procedure Start_Prefix_Mapping (Handler : in out Xhtml_Reader; 113 Prefix : in Unicode.CES.Byte_Sequence; 114 URI : in Unicode.CES.Byte_Sequence) is 115 begin 116 null; 117 end Start_Prefix_Mapping; 118 119 -- ------------------------------ 120 -- End_Prefix_Mapping 121 -- ------------------------------ 122 overriding 123 procedure End_Prefix_Mapping (Handler : in out Xhtml_Reader; 124 Prefix : in Unicode.CES.Byte_Sequence) is 125 begin 126 null; 127 end End_Prefix_Mapping; 128 129 -- ------------------------------ 130 -- Start_Element 131 -- ------------------------------ 132 overriding 133 procedure Start_Element (Handler : in out Xhtml_Reader; 134 Namespace_URI : in Unicode.CES.Byte_Sequence := ""; 135 Local_Name : in Unicode.CES.Byte_Sequence := ""; 136 Qname : in Unicode.CES.Byte_Sequence := ""; 137 Atts : in Sax.Attributes.Attributes'Class) is 138 pragma Unreferenced (Namespace_URI, Qname); 139 140 Attr_Count : Natural; 141 begin 142 Log.Debug ("Start object {0}", Local_Name); 143 144 Handler.Handler.Start_Object (Local_Name); 145 Attr_Count := Get_Length (Atts); 146 for I in 0 .. Attr_Count - 1 loop 147 declare 148 Name : constant String := Get_Qname (Atts, I); 149 Value : constant String := Get_Value (Atts, I); 150 begin 151 Handler.Handler.Set_Member (Name => Name, 152 Value => Util.Beans.Objects.To_Object (Value), 153 Attribute => True); 154 end; 155 end loop; 156 end Start_Element; 157 158 -- ------------------------------ 159 -- End_Element 160 -- ------------------------------ 161 overriding 162 procedure End_Element (Handler : in out Xhtml_Reader; 163 Namespace_URI : in Unicode.CES.Byte_Sequence := ""; 164 Local_Name : in Unicode.CES.Byte_Sequence := ""; 165 Qname : in Unicode.CES.Byte_Sequence := "") is 166 pragma Unreferenced (Namespace_URI, Qname); 167 168 Len : constant Natural := Length (Handler.Text); 169 begin 170 Handler.Handler.Finish_Object (Local_Name); 171 if Len > 0 then 172 173 -- Add debug message only when it is active (saves the To_String conversion). 174 if Log.Get_Level >= Util.Log.DEBUG_LEVEL then 175 Log.Debug ("Close object {0} -> {1}", Local_Name, To_String (Handler.Text)); 176 end if; 177 Handler.Handler.Set_Member (Local_Name, Util.Beans.Objects.To_Object (Handler.Text)); 178 179 -- Clear the string using Delete so that the buffer is kept. 180 Ada.Strings.Unbounded.Delete (Source => Handler.Text, From => 1, Through => Len); 181 else 182 Log.Debug ("Close object {0}", Local_Name); 183 Handler.Handler.Set_Member (Local_Name, Util.Beans.Objects.To_Object (Handler.Text)); 184 end if; 185 end End_Element; 186 187 procedure Collect_Text (Handler : in out Xhtml_Reader; 188 Content : Unicode.CES.Byte_Sequence) is 189 begin 190 Append (Handler.Text, Content); 191 end Collect_Text; 192 193 -- ------------------------------ 194 -- Characters 195 -- ------------------------------ 196 overriding 197 procedure Characters (Handler : in out Xhtml_Reader; 198 Ch : in Unicode.CES.Byte_Sequence) is 199 begin 200 Collect_Text (Handler, Ch); 201 end Characters; 202 203 -- ------------------------------ 204 -- Ignorable_Whitespace 205 -- ------------------------------ 206 overriding 207 procedure Ignorable_Whitespace (Handler : in out Xhtml_Reader; 208 Ch : in Unicode.CES.Byte_Sequence) is 209 begin 210 if not Handler.Ignore_White_Spaces then 211 Collect_Text (Handler, Ch); 212 end if; 213 end Ignorable_Whitespace; 214 215 -- ------------------------------ 216 -- Processing_Instruction 217 -- ------------------------------ 218 overriding 219 procedure Processing_Instruction (Handler : in out Xhtml_Reader; 220 Target : in Unicode.CES.Byte_Sequence; 221 Data : in Unicode.CES.Byte_Sequence) is 222 pragma Unreferenced (Handler); 223 begin 224 Log.Error ("Processing instruction: {0}: {1}", Target, Data); 225 end Processing_Instruction; 226 227 -- ------------------------------ 228 -- Skipped_Entity 229 -- ------------------------------ 230 overriding 231 procedure Skipped_Entity (Handler : in out Xhtml_Reader; 232 Name : in Unicode.CES.Byte_Sequence) is 233 pragma Unmodified (Handler); 234 begin 235 null; 236 end Skipped_Entity; 237 238 -- ------------------------------ 239 -- Start_Cdata 240 -- ------------------------------ 241 overriding 242 procedure Start_Cdata (Handler : in out Xhtml_Reader) is 243 pragma Unmodified (Handler); 244 pragma Unreferenced (Handler); 245 begin 246 Log.Info ("Start CDATA"); 247 end Start_Cdata; 248 249 -- ------------------------------ 250 -- End_Cdata 251 -- ------------------------------ 252 overriding 253 procedure End_Cdata (Handler : in out Xhtml_Reader) is 254 pragma Unmodified (Handler); 255 pragma Unreferenced (Handler); 256 begin 257 Log.Info ("End CDATA"); 258 end End_Cdata; 259 260 -- ------------------------------ 261 -- Resolve_Entity 262 -- ------------------------------ 263 overriding 264 function Resolve_Entity (Handler : Xhtml_Reader; 265 Public_Id : Unicode.CES.Byte_Sequence; 266 System_Id : Unicode.CES.Byte_Sequence) 267 return Input_Sources.Input_Source_Access is 268 pragma Unreferenced (Handler); 269 begin 270 Log.Error ("Cannot resolve entity {0} - {1}", Public_Id, System_Id); 271 return null; 272 end Resolve_Entity; 273 274 overriding 275 procedure Start_DTD (Handler : in out Xhtml_Reader; 276 Name : Unicode.CES.Byte_Sequence; 277 Public_Id : Unicode.CES.Byte_Sequence := ""; 278 System_Id : Unicode.CES.Byte_Sequence := "") is 279 begin 280 null; 281 end Start_DTD; 282 283 -- ------------------------------ 284 -- Set the XHTML reader to ignore or not the white spaces. 285 -- When set to True, the ignorable white spaces will not be kept. 286 -- ------------------------------ 287 procedure Set_Ignore_White_Spaces (Reader : in out Parser; 288 Value : in Boolean) is 289 begin 290 Reader.Ignore_White_Spaces := Value; 291 end Set_Ignore_White_Spaces; 292 293 -- ------------------------------ 294 -- Set the XHTML reader to ignore empty lines. 295 -- ------------------------------ 296 procedure Set_Ignore_Empty_Lines (Reader : in out Parser; 297 Value : in Boolean) is 298 begin 299 Reader.Ignore_Empty_Lines := Value; 300 end Set_Ignore_Empty_Lines; 301 302 -- ------------------------------ 303 -- Get the current location (file and line) to report an error message. 304 -- ------------------------------ 305 function Get_Location (Handler : in Parser) return String is 306 File : constant String := Util.Serialize.IO.Parser (Handler).Get_Location; 307 begin 308 if Handler.Locator = Sax.Locators.No_Locator then 309 return File; 310 else 311 return File & Sax.Locators.To_String (Handler.Locator); 312 end if; 313 end Get_Location; 314 315 -- ------------------------------ 316 -- Parse an XML stream, and calls the appropriate SAX callbacks for each 317 -- event. 318 -- This is not re-entrant: you can not call Parse with the same Parser 319 -- argument in one of the SAX callbacks. This has undefined behavior. 320 -- ------------------------------ 321 322 -- Parse the stream using the JSON parser. 323 procedure Parse (Handler : in out Parser; 324 Stream : in out Util.Streams.Buffered.Buffered_Stream'Class) is 325 326 Buffer_Size : constant Positive := 256; 327 328 type String_Access is access all String (1 .. Buffer_Size); 329 330 type Stream_Input is new Input_Sources.Input_Source with record 331 Index : Natural; 332 Last : Natural; 333 Encoding : Unicode.CES.Encoding_Scheme; 334 Buffer : String_Access; 335 end record; 336 337 -- Return the next character in the string. 338 procedure Next_Char (From : in out Stream_Input; 339 C : out Unicode.Unicode_Char); 340 341 -- True if From is past the last character in the string. 342 function Eof (From : in Stream_Input) return Boolean; 343 procedure Fill (From : in out Stream_Input'Class); 344 345 procedure Fill (From : in out Stream_Input'Class) is 346 Last : Natural := From.Last; 347 begin 348 -- Move to the buffer start 349 if Last > From.Index and From.Index > From.Buffer'First then 350 From.Buffer (From.Buffer'First .. Last - 1 - From.Index + From.Buffer'First) := 351 From.Buffer (From.Index .. Last - 1); 352 Last := Last - From.Index + From.Buffer'First; 353 From.Index := From.Buffer'First; 354 end if; 355 if From.Index > From.Last then 356 From.Index := From.Buffer'First; 357 end if; 358 begin 359 loop 360 Stream.Read (From.Buffer (Last)); 361 Last := Last + 1; 362 exit when Last > From.Buffer'Last; 363 end loop; 364 exception 365 when others => 366 null; 367 end; 368 From.Last := Last; 369 end Fill; 370 371 -- Return the next character in the string. 372 procedure Next_Char (From : in out Stream_Input; 373 C : out Unicode.Unicode_Char) is 374 begin 375 if From.Index + 6 >= From.Last then 376 Fill (From); 377 end if; 378 From.Encoding.Read (From.Buffer.all, From.Index, C); 379 end Next_Char; 380 381 -- True if From is past the last character in the string. 382 function Eof (From : in Stream_Input) return Boolean is 383 begin 384 if From.Index < From.Last then 385 return False; 386 end if; 387 return Stream.Is_Eof; 388 end Eof; 389 390 Input : Stream_Input; 391 Xml_Parser : Xhtml_Reader; 392 Buf : aliased String (1 .. Buffer_Size); 393 begin 394 Input.Buffer := Buf'Access; 395 Input.Index := Buf'First + 1; 396 Input.Last := Buf'First; 397 Input.Set_Encoding (Unicode.CES.Utf8.Utf8_Encoding); 398 Input.Encoding := Unicode.CES.Utf8.Utf8_Encoding; 399 Xml_Parser.Handler := Handler'Unchecked_Access; 400 Xml_Parser.Ignore_White_Spaces := Handler.Ignore_White_Spaces; 401 Xml_Parser.Ignore_Empty_Lines := Handler.Ignore_Empty_Lines; 402 Sax.Readers.Reader (Xml_Parser).Parse (Input); 403 Handler.Locator := Sax.Locators.No_Locator; 404 405 -- Ignore the Program_Error exception that SAX could raise if we know that the 406 -- error was reported. 407 exception 408 when Program_Error => 409 Handler.Locator := Sax.Locators.No_Locator; 410 if not Handler.Has_Error then 411 raise; 412 end if; 413 414 when others => 415 Handler.Locator := Sax.Locators.No_Locator; 416 raise; 417 end Parse; 418 419 -- Close the current XML entity if an entity was started 420 procedure Close_Current (Stream : in out Output_Stream'Class); 421 422 -- ------------------------------ 423 -- Close the current XML entity if an entity was started 424 -- ------------------------------ 425 procedure Close_Current (Stream : in out Output_Stream'Class) is 426 begin 427 if Stream.Close_Start then 428 Stream.Write ('>'); 429 Stream.Close_Start := False; 430 end if; 431 end Close_Current; 432 433 -- ------------------------------ 434 -- Write the value as a XML string. Special characters are escaped using the XML 435 -- escape rules. 436 -- ------------------------------ 437 procedure Write_String (Stream : in out Output_Stream; 438 Value : in String) is 439 begin 440 Close_Current (Stream); 441 Stream.Write (Value); 442 end Write_String; 443 444 -- ------------------------------ 445 -- Write the value as a XML string. Special characters are escaped using the XML 446 -- escape rules. 447 -- ------------------------------ 448 procedure Write_String (Stream : in out Output_Stream; 449 Value : in Util.Beans.Objects.Object) is 450 use Util.Beans.Objects; 451 begin 452 Close_Current (Stream); 453 case Util.Beans.Objects.Get_Type (Value) is 454 when TYPE_NULL => 455 null; 456 457 when TYPE_BOOLEAN => 458 if Util.Beans.Objects.To_Boolean (Value) then 459 Stream.Write ("true"); 460 else 461 Stream.Write ("false"); 462 end if; 463 464 when TYPE_INTEGER => 465 Stream.Write (Util.Beans.Objects.To_Long_Long_Integer (Value)); 466 467 when others => 468 Stream.Write_String (Util.Beans.Objects.To_String (Value)); 469 470 end case; 471 end Write_String; 472 473 -- ------------------------------ 474 -- Start a new XML object. 475 -- ------------------------------ 476 procedure Start_Entity (Stream : in out Output_Stream; 477 Name : in String) is 478 begin 479 Close_Current (Stream); 480 Stream.Close_Start := True; 481 Stream.Write ('<'); 482 Stream.Write (Name); 483 end Start_Entity; 484 485 -- ------------------------------ 486 -- Terminates the current XML object. 487 -- ------------------------------ 488 procedure End_Entity (Stream : in out Output_Stream; 489 Name : in String) is 490 begin 491 Close_Current (Stream); 492 Stream.Write ("</"); 493 Stream.Write (Name); 494 Stream.Write ('>'); 495 end End_Entity; 496 497 -- ------------------------------ 498 -- Write a XML name/value attribute. 499 -- ------------------------------ 500 procedure Write_Attribute (Stream : in out Output_Stream; 501 Name : in String; 502 Value : in Util.Beans.Objects.Object) is 503 use Util.Beans.Objects; 504 begin 505 Stream.Write (' '); 506 Stream.Write (Name); 507 Stream.Write ("="""); 508 case Util.Beans.Objects.Get_Type (Value) is 509 when TYPE_NULL => 510 null; 511 512 when TYPE_BOOLEAN => 513 if Util.Beans.Objects.To_Boolean (Value) then 514 Stream.Write ("true"); 515 else 516 Stream.Write ("false"); 517 end if; 518 519 when TYPE_INTEGER => 520 Stream.Write (Util.Beans.Objects.To_Long_Long_Integer (Value)); 521 522 when others => 523 Stream.Write (Util.Beans.Objects.To_String (Value)); 524 525 end case; 526 Stream.Write ('"'); 527 end Write_Attribute; 528 529 -- ------------------------------ 530 -- Write a XML name/value entity (see Write_Attribute). 531 -- ------------------------------ 532 procedure Write_Entity (Stream : in out Output_Stream; 533 Name : in String; 534 Value : in Util.Beans.Objects.Object) is 535 use Util.Beans.Objects; 536 begin 537 Close_Current (Stream); 538 Stream.Write ('<'); 539 Stream.Write (Name); 540 Stream.Close_Start := True; 541 Stream.Write_String (Value); 542 Stream.Write ("</"); 543 Stream.Write (Name); 544 Stream.Write ('>'); 545 end Write_Entity; 546 547 -- ------------------------------ 548 -- Starts a XML array. 549 -- ------------------------------ 550 procedure Start_Array (Stream : in out Output_Stream; 551 Length : in Ada.Containers.Count_Type) is 552 begin 553 null; 554 end Start_Array; 555 556 -- ------------------------------ 557 -- Terminates a XML array. 558 -- ------------------------------ 559 procedure End_Array (Stream : in out Output_Stream) is 560 begin 561 null; 562 end End_Array; 563 564end Util.Serialize.IO.XML; 565