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------------------------------------------------------------------------------ 44with League.Characters.Internals; 45with League.Characters.Latin; 46with Matreshka.Internals.Unicode; 47 48package body XML.SAX.Pretty_Writers is 49 50 use Matreshka.Internals.Unicode; 51 use type League.Strings.Universal_String; 52 53 XML_Namespace : constant League.Strings.Universal_String 54 := League.Strings.To_Universal_String 55 ("http://www.w3.org/XML/1998/namespace"); 56 XML_Prefix : constant League.Strings.Universal_String 57 := League.Strings.To_Universal_String ("xml"); 58 XMLNS_Prefix : constant League.Strings.Universal_String 59 := League.Strings.To_Universal_String ("xmlns"); 60 Amp_Entity_Reference : constant League.Strings.Universal_String 61 := League.Strings.To_Universal_String ("&"); 62 Apos_Entity_Reference : constant League.Strings.Universal_String 63 := League.Strings.To_Universal_String ("'"); 64 Quot_Entity_Reference : constant League.Strings.Universal_String 65 := League.Strings.To_Universal_String ("""); 66 Gt_Entity_Reference : constant League.Strings.Universal_String 67 := League.Strings.To_Universal_String (">"); 68 Lt_Entity_Reference : constant League.Strings.Universal_String 69 := League.Strings.To_Universal_String ("<"); 70 XML_1_0_Image : constant League.Strings.Universal_String 71 := League.Strings.To_Universal_String ("1.0"); 72 XML_1_1_Image : constant League.Strings.Universal_String 73 := League.Strings.To_Universal_String ("1.1"); 74 75 procedure Output_Name 76 (Self : in out XML_Pretty_Writer; 77 Namespace_URI : League.Strings.Universal_String; 78 Local_Name : League.Strings.Universal_String; 79 Qualified_Name : League.Strings.Universal_String; 80 Success : in out Boolean); 81 -- Do vilidity checks, resolve namespace prefix when necessary and output 82 -- name (of the tag or attribute). 83 84 function Image (X_V : XML_Version) return League.Strings.Universal_String; 85 -- Returns text representation of XML version. 86 87 ---------------- 88 -- Characters -- 89 ---------------- 90 91 overriding procedure Characters 92 (Self : in out XML_Pretty_Writer; 93 Text : League.Strings.Universal_String; 94 Success : in out Boolean) 95 is 96 pragma Unreferenced (Success); 97 98 begin 99 if Self.Tag_Opened then 100 Self.Destination.Put ('>'); 101 Self.Tag_Opened := False; 102 end if; 103 104 Self.Destination.Put (Self.Escape (Text)); 105 Self.Chars := True; 106 end Characters; 107 108 ------------- 109 -- Comment -- 110 ------------- 111 112 overriding procedure Comment 113 (Self : in out XML_Pretty_Writer; 114 Text : League.Strings.Universal_String; 115 Success : in out Boolean) 116 is 117 pragma Unreferenced (Success); 118 119 begin 120 -- Closing DTD, which was opened before. 121 122 if Self.DTD_Opened then 123 Self.Destination.Put ('>'); 124 Self.DTD_Opened := False; 125 end if; 126 127 Self.Destination.Put ("<!-- "); 128 Self.Destination.Put (Text); 129 Self.Destination.Put (" -->"); 130 end Comment; 131 132 --------------- 133 -- End_CDATA -- 134 --------------- 135 136 overriding procedure End_CDATA 137 (Self : in out XML_Pretty_Writer; 138 Success : in out Boolean) is 139 begin 140 null; 141 end End_CDATA; 142 143 ------------------ 144 -- End_Document -- 145 ------------------ 146 147 overriding procedure End_Document 148 (Self : in out XML_Pretty_Writer; 149 Success : in out Boolean) is 150 begin 151 if Self.Nesting /= 0 then 152 Success := False; 153 return; 154 end if; 155 end End_Document; 156 157 ------------- 158 -- End_DTD -- 159 ------------- 160 161 overriding procedure End_DTD 162 (Self : in out XML_Pretty_Writer; 163 Success : in out Boolean) 164 is 165 pragma Unreferenced (Success); 166 167 begin 168 Self.Destination.Put ('>'); 169 Self.DTD_Opened := False; 170 end End_DTD; 171 172 ----------------- 173 -- End_Element -- 174 ----------------- 175 176 overriding procedure End_Element 177 (Self : in out XML_Pretty_Writer; 178 Namespace_URI : League.Strings.Universal_String; 179 Local_Name : League.Strings.Universal_String; 180 Qualified_Name : League.Strings.Universal_String; 181 Success : in out Boolean) is 182 begin 183 -- Validity check: Namespace_URI, Local_Name and Qualified_Name of close 184 -- tag must match open tag. 185 186 if Self.Current.Namespace_URI /= Namespace_URI 187 or Self.Current.Local_Name /= Local_Name 188 or Self.Current.Qualified_Name /= Qualified_Name 189 then 190 Self.Error := 191 League.Strings.To_Universal_String 192 ("namespace URI, local name or qualified name doesn't match" 193 & " open tag"); 194 Success := False; 195 196 return; 197 end if; 198 199 -- Use empty tag when there are no any content inside the tag. 200 201 if Self.Tag_Opened then 202 Self.Destination.Put ("/>"); 203 Self.Tag_Opened := False; 204 205 -- Do automatic indentation then necessary. 206 207 if Self.Offset /= 0 then 208 Self.Indent := Self.Indent - Self.Offset; 209 end if; 210 211 else 212 -- Do automatic indentation then necessary. 213 214 if Self.Offset /= 0 then 215 Self.Indent := Self.Indent - Self.Offset; 216 217 if Self.Chars then 218 Self.Chars := False; 219 220 else 221 Self.Destination.Put (League.Characters.Latin.Line_Feed); 222 223 for J in 1 .. Self.Indent loop 224 Self.Destination.Put (' '); 225 end loop; 226 end if; 227 end if; 228 229 Self.Destination.Put ("</"); 230 Output_Name (Self, Namespace_URI, Local_Name, Qualified_Name, Success); 231 Self.Destination.Put ('>'); 232 end if; 233 234 -- Pop current element information. 235 236 Self.Current := Self.Stack.Last_Element; 237 Self.Stack.Delete_Last; 238 239 Self.Nesting := Self.Nesting - 1; 240 end End_Element; 241 242 ---------------- 243 -- End_Entity -- 244 ---------------- 245 246 overriding procedure End_Entity 247 (Self : in out XML_Pretty_Writer; 248 Name : League.Strings.Universal_String; 249 Success : in out Boolean) is 250 begin 251 null; 252 end End_Entity; 253 254 ------------------------ 255 -- End_Prefix_Mapping -- 256 ------------------------ 257 258 overriding procedure End_Prefix_Mapping 259 (Self : in out XML_Pretty_Writer; 260 Prefix : League.Strings.Universal_String 261 := League.Strings.Empty_Universal_String; 262 Success : in out Boolean) is 263 begin 264 null; 265 end End_Prefix_Mapping; 266 267 ------------------ 268 -- Error_String -- 269 ------------------ 270 271 overriding function Error_String 272 (Self : XML_Pretty_Writer) return League.Strings.Universal_String is 273 begin 274 return Self.Error; 275 end Error_String; 276 277 ------------ 278 -- Escape -- 279 ------------ 280 281 function Escape 282 (Self : XML_Pretty_Writer; 283 Text : League.Strings.Universal_String; 284 Escape_All : Boolean := False) 285 return League.Strings.Universal_String 286 is 287 Code : Code_Point; 288 289 begin 290 return Result : League.Strings.Universal_String do 291 for J in 1 .. Text.Length loop 292 Code := League.Characters.Internals.Internal (Text.Element (J)); 293 294 case Text.Element (J).To_Wide_Wide_Character is 295 when '&' => 296 Result.Append (Amp_Entity_Reference); 297 298 when ''' => 299 if Escape_All then 300 Result.Append (Apos_Entity_Reference); 301 else 302 Result.Append (Text.Element (J).To_Wide_Wide_Character); 303 end if; 304 305 when '"' => 306 if Escape_All then 307 Result.Append (Quot_Entity_Reference); 308 else 309 Result.Append (Text.Element (J).To_Wide_Wide_Character); 310 end if; 311 312 when '>' => 313 if Escape_All then 314 Result.Append (Gt_Entity_Reference); 315 else 316 Result.Append (Text.Element (J).To_Wide_Wide_Character); 317 end if; 318 319 when '<' => 320 Result.Append (Lt_Entity_Reference); 321 322 when others => 323 -- Add support of choosing of Hexademical 324 -- or Digital representation of Character references 325 -- XML_1_1 2.2 Characters 326 327 if Self.Version = XML_1_1 and then 328 (Code in 16#1# .. 16#8# 329 or else Code in 16#B# .. 16#C# 330 or else Code in 16#E# .. 16#1F# 331 or else Code in 16#7F# .. 16#84# 332 or else Code in 16#86# .. 16#9F#) 333 then 334 declare 335 Image : constant Wide_Wide_String := 336 Code_Unit_32'Wide_Wide_Image (Code); 337 338 begin 339 Result := Result 340 & "&#" 341 & Image (Image'First + 1 .. Image'Last) 342 & ";"; 343 end; 344 else 345 Result.Append (Text.Element (J).To_Wide_Wide_Character); 346 end if; 347 end case; 348 end loop; 349 end return; 350 end Escape; 351 352 -------------------------- 353 -- Ignorable_Whitespace -- 354 -------------------------- 355 356 overriding procedure Ignorable_Whitespace 357 (Self : in out XML_Pretty_Writer; 358 Text : League.Strings.Universal_String; 359 Success : in out Boolean) is 360 begin 361 null; 362 end Ignorable_Whitespace; 363 364 ----------- 365 -- Image -- 366 ----------- 367 368 function Image (X_V : XML_Version) return League.Strings.Universal_String is 369 begin 370 case X_V is 371 when XML_1_0 => 372 return XML_1_0_Image; 373 374 when XML_1_1 => 375 return XML_1_1_Image; 376 end case; 377 end Image; 378 379 ----------- 380 -- Merge -- 381 ----------- 382 383 procedure Merge (Current : in out Mappings.Map; Bank : Banks.Map) is 384 C : Banks.Cursor := Banks.First (Bank); 385 386 begin 387 while Banks.Has_Element (C) loop 388 Mappings.Include (Current, Banks.Key (C), Banks.Element (C)); 389 Banks.Next (C); 390 end loop; 391 end Merge; 392 393 ----------------- 394 -- Output_Name -- 395 ----------------- 396 397 procedure Output_Name 398 (Self : in out XML_Pretty_Writer; 399 Namespace_URI : League.Strings.Universal_String; 400 Local_Name : League.Strings.Universal_String; 401 Qualified_Name : League.Strings.Universal_String; 402 Success : in out Boolean) is 403 begin 404 if Namespace_URI.Is_Empty then 405 -- Non-namespaces mode. 406 407 -- Validity check: Qualified_Name must not be empty. 408 409 if Qualified_Name.Is_Empty then 410 Self.Error := 411 League.Strings.To_Universal_String ("qualified name is empty"); 412 Success := False; 413 414 return; 415 end if; 416 417 -- Append qualified name of the tag. 418 419 Self.Destination.Put (Qualified_Name); 420 421 else 422 -- Namespaces mode. 423 424 -- Validity check: local name must not be empty. 425 426 if Local_Name.Is_Empty then 427 Self.Error := 428 League.Strings.To_Universal_String 429 ("namespace is provides but local name is empty"); 430 Success := False; 431 432 return; 433 end if; 434 435 -- Lookup for namespace prefix. 436 437 declare 438 Position : constant Mappings.Cursor 439 := Self.Current.Mapping.Find (Namespace_URI); 440 441 begin 442 if not Mappings.Has_Element (Position) then 443 Self.Error := 444 League.Strings.To_Universal_String 445 ("namespace is not mapped to any prefix"); 446 Success := False; 447 448 return; 449 end if; 450 451 -- Output namespace prexif when namespace is not default. 452 453 if not Mappings.Element (Position).Is_Empty then 454 Self.Destination.Put (Mappings.Element (Position)); 455 Self.Destination.Put (':'); 456 end if; 457 end; 458 459 Self.Destination.Put (Local_Name); 460 end if; 461 end Output_Name; 462 463 ---------------------------- 464 -- Processing_Instruction -- 465 ---------------------------- 466 467 overriding procedure Processing_Instruction 468 (Self : in out XML_Pretty_Writer; 469 Target : League.Strings.Universal_String; 470 Data : League.Strings.Universal_String; 471 Success : in out Boolean) 472 is 473 pragma Unreferenced (Success); 474 475 begin 476 -- Closing DTD, which was opened before. 477 478 if Self.DTD_Opened then 479 Self.Destination.Put ('>'); 480 Self.DTD_Opened := False; 481 end if; 482 end Processing_Instruction; 483 484 ---------------- 485 -- Set_Offset -- 486 ---------------- 487 488 not overriding procedure Set_Offset 489 (Self : in out XML_Pretty_Writer; 490 Offset : Natural) is 491 begin 492 Self.Offset := Offset; 493 end Set_Offset; 494 495 ---------------------------- 496 -- Set_Output_Destination -- 497 ---------------------------- 498 499 procedure Set_Output_Destination 500 (Self : in out XML_Pretty_Writer'Class; 501 Output : not null SAX_Output_Destination_Access) is 502 begin 503 Self.Destination := Output; 504 end Set_Output_Destination; 505 506 ------------------------- 507 -- Set_Value_Delimiter -- 508 ------------------------- 509 not overriding procedure Set_Value_Delimiter 510 (Self : in out XML_Pretty_Writer; 511 Delimiter : League.Characters.Universal_Character) is 512 begin 513 Self.Delimiter := Delimiter; 514 end Set_Value_Delimiter; 515 516 ----------------- 517 -- Set_Version -- 518 ----------------- 519 520 procedure Set_Version 521 (Self : in out XML_Pretty_Writer; 522 Version : XML_Version) is 523 begin 524 Self.Version := Version; 525 end Set_Version; 526 527 -------------------- 528 -- Skipped_Entity -- 529 -------------------- 530 531 overriding procedure Skipped_Entity 532 (Self : in out XML_Pretty_Writer; 533 Name : League.Strings.Universal_String; 534 Success : in out Boolean) is 535 begin 536 null; 537 end Skipped_Entity; 538 539 ----------------- 540 -- Start_CDATA -- 541 ----------------- 542 543 overriding procedure Start_CDATA 544 (Self : in out XML_Pretty_Writer; 545 Success : in out Boolean) is 546 begin 547 null; 548 end Start_CDATA; 549 550 -------------------- 551 -- Start_Document -- 552 -------------------- 553 554 overriding procedure Start_Document 555 (Self : in out XML_Pretty_Writer; 556 Success : in out Boolean) 557 is 558 pragma Unreferenced (Success); 559 560 begin 561 Self.Destination.Put 562 (League.Strings.To_Universal_String ("<?xml version=") 563 & Self.Delimiter 564 & Image (Self.Version) 565 & Self.Delimiter 566 & "?>"); 567 Self.Nesting := 0; 568 569 -- Reset namespace mapping and initialize it by XML namespace URI mapped 570 -- to 'xml' prefix. 571 572 Self.Current.Mapping.Clear; 573 Self.Current.Mapping.Insert (XML_Namespace, XML_Prefix); 574 end Start_Document; 575 576 --------------- 577 -- Start_DTD -- 578 --------------- 579 580 overriding procedure Start_DTD 581 (Self : in out XML_Pretty_Writer; 582 Name : League.Strings.Universal_String; 583 Public_Id : League.Strings.Universal_String; 584 System_Id : League.Strings.Universal_String; 585 Success : in out Boolean) 586 is 587 pragma Unreferenced (Success); 588 589 begin 590 Self.Destination.Put ("<!DOCTYPE " & Name); 591 592 if not Public_Id.Is_Empty then 593 Self.Destination.Put (" PUBLIC " & Public_Id & " " & System_Id); 594 595 elsif not System_Id.Is_Empty then 596 Self.Destination.Put (" SYSTEM' " & System_Id); 597 end if; 598 599 Self.DTD_Opened := True; 600 end Start_DTD; 601 602 ------------------- 603 -- Start_Element -- 604 ------------------- 605 606 overriding procedure Start_Element 607 (Self : in out XML_Pretty_Writer; 608 Namespace_URI : League.Strings.Universal_String; 609 Local_Name : League.Strings.Universal_String; 610 Qualified_Name : League.Strings.Universal_String; 611 Attributes : XML.SAX.Attributes.SAX_Attributes; 612 Success : in out Boolean) is 613 begin 614 -- Closing DTD, which was opened before. 615 616 if Self.DTD_Opened then 617 Self.Destination.Put ('>'); 618 Self.DTD_Opened := False; 619 end if; 620 621 -- Closing Tag, which was opened before. 622 623 if Self.Tag_Opened then 624 Self.Destination.Put ('>'); 625 Self.Tag_Opened := False; 626 end if; 627 628 -- Push to stack current element and namespace mapping 629 630 Self.Stack.Append (Self.Current); 631 632 Self.Current.Namespace_URI := Namespace_URI; 633 Self.Current.Local_Name := Local_Name; 634 Self.Current.Qualified_Name := Qualified_Name; 635 636 if not Self.Requested_NS.Is_Empty then 637 -- Append Bank and Current namespaces. 638 639 Merge (Self.Current.Mapping, Self.Requested_NS); 640 end if; 641 642 if Self.Offset /= 0 then 643 -- Do automatic indentation when necessary. 644 645 if Self.Chars then 646 Self.Chars := False; 647 648 else 649 Self.Destination.Put (League.Characters.Latin.Line_Feed); 650 651 for J in 1 .. Self.Indent loop 652 Self.Destination.Put (' '); 653 end loop; 654 end if; 655 656 Self.Indent := Self.Indent + Self.Offset; 657 end if; 658 659 Self.Destination.Put ('<'); 660 Output_Name (Self, Namespace_URI, Local_Name, Qualified_Name, Success); 661 662 if not Success then 663 return; 664 end if; 665 666 -- Output namespace mappings. 667 668 declare 669 Position : Banks.Cursor := Self.Requested_NS.First; 670 671 begin 672 while Banks.Has_Element (Position) loop 673 Self.Destination.Put (' '); 674 Self.Destination.Put (XMLNS_Prefix); 675 676 if not Banks.Element (Position).Is_Empty then 677 -- Non-default prefix. 678 679 Self.Destination.Put (':'); 680 Self.Destination.Put (Banks.Element (Position)); 681 end if; 682 683 Self.Destination.Put ('='); 684 Self.Destination.Put (Self.Delimiter); 685 Self.Destination.Put (Banks.Key (Position)); 686 Self.Destination.Put (Self.Delimiter); 687 688 Banks.Next (Position); 689 end loop; 690 end; 691 692 -- Output attributes. 693 694 for J in 1 .. Attributes.Length loop 695 Self.Destination.Put (' '); 696 Output_Name 697 (Self, 698 Attributes.Namespace_URI (J), 699 Attributes.Local_Name (J), 700 Attributes.Qualified_Name (J), 701 Success); 702 703 if not Success then 704 return; 705 end if; 706 707 Self.Destination.Put ("="); 708 Self.Destination.Put (Self.Delimiter); 709 Self.Destination.Put (Self.Escape (Attributes.Value (J), True)); 710 Self.Destination.Put (Self.Delimiter); 711 end loop; 712 713 Self.Nesting := Self.Nesting + 1; 714 Self.Tag_Opened := True; 715 Self.Requested_NS.Clear; 716 end Start_Element; 717 718 ------------------ 719 -- Start_Entity -- 720 ------------------ 721 722 overriding procedure Start_Entity 723 (Self : in out XML_Pretty_Writer; 724 Name : League.Strings.Universal_String; 725 Success : in out Boolean) is 726 begin 727 null; 728 end Start_Entity; 729 730 -------------------------- 731 -- Start_Prefix_Mapping -- 732 -------------------------- 733 734 overriding procedure Start_Prefix_Mapping 735 (Self : in out XML_Pretty_Writer; 736 Prefix : League.Strings.Universal_String 737 := League.Strings.Empty_Universal_String; 738 Namespace_URI : League.Strings.Universal_String; 739 Success : in out Boolean) is 740 begin 741 if Namespace_URI.Is_Empty then 742 -- XXX error should be reported 743 Success := False; 744 return; 745 end if; 746 747 -- Append prefix mapping, to temp set of mapping scope 748 749 Self.Requested_NS.Include (Namespace_URI, Prefix); 750 end Start_Prefix_Mapping; 751 752end XML.SAX.Pretty_Writers; 753