1------------------------------------------------------------------------------ 2-- GtkAda - Ada95 binding for the Gimp Toolkit -- 3-- -- 4-- Copyright (C) 1998-2000 E. Briot, J. Brobecker and A. Charlet -- 5-- Copyright (C) 1998-2015, AdaCore -- 6-- -- 7-- This library is free software; you can redistribute it and/or modify it -- 8-- under terms of the GNU General Public License as published by the Free -- 9-- Software Foundation; either version 3, or (at your option) any later -- 10-- version. This library is distributed in the hope that it will be useful, -- 11-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 12-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 13-- -- 14-- As a special exception under Section 7 of GPL version 3, you are granted -- 15-- additional permissions described in the GCC Runtime Library Exception, -- 16-- version 3.1, as published by the Free Software Foundation. -- 17-- -- 18-- You should have received a copy of the GNU General Public License and -- 19-- a copy of the GCC Runtime Library Exception along with this program; -- 20-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 21-- <http://www.gnu.org/licenses/>. -- 22-- -- 23------------------------------------------------------------------------------ 24 25with Ada.Strings.Fixed; use Ada.Strings.Fixed; 26with Glib.Convert; use Glib.Convert; 27with Glib.Error; use Glib.Error; 28with Glib.Unicode; use Glib.Unicode; 29with Glib.Messages; use Glib.Messages; 30 31package body Glib.XML is 32 33 function File_Length (FD : Integer) return Long_Integer; 34 pragma Import (C, File_Length, "__gnat_file_length"); 35 -- Get length of file from file descriptor FD 36 37 function Open_Read 38 (Name : String; 39 Fmode : Integer := 0) return Integer; 40 pragma Import (C, Open_Read, "__gnat_open_read"); 41 -- Open file Name and return a file descriptor 42 43 function Create_File 44 (Name : String; 45 Fmode : Integer := 0) return Integer; 46 pragma Import (C, Create_File, "__gnat_open_create"); 47 -- Creates new file with given name for writing, returning file descriptor 48 -- for subsequent use in Write calls. File descriptor returned is 49 -- negative if file cannot be successfully created. 50 51 function Read 52 (FD : Integer; 53 A : System.Address; 54 N : Integer) return Integer; 55 pragma Import (C, Read, "read"); 56 -- Read N bytes to address A from file referenced by FD. Returned value is 57 -- count of bytes actually read, which can be less than N at EOF. 58 59 procedure Write 60 (FD : Integer; 61 S : String; 62 N : Integer); 63 pragma Import (C, Write, "write"); 64 -- Write N bytes from address A to file referenced by FD. The returned 65 -- value is the number of bytes written, which can be less than N if a 66 -- disk full condition was detected. 67 68 procedure Close (FD : Integer); 69 pragma Import (C, Close, "close"); 70 -- Close file referenced by FD 71 72 procedure Skip_Blanks (Buf : String; Index : in out Natural); 73 -- Skip blanks, LF and CR, starting at Index. Index is updated to the 74 -- new position (first non blank or EOF) 75 76 function Get_Node (Buf : String; Index : access Natural) return Node_Ptr; 77 -- The main parse routine. Starting at Index.all, Index.all is updated 78 -- on return. Return the node starting at Buf (Index.all) which will 79 -- also contain all the children and subchildren. 80 81 procedure Get_Buf 82 (Buf : String; 83 Index : in out Natural; 84 Terminator : Character; 85 S : out String_Ptr); 86 -- On return, S will contain the String starting at Buf (Index) and 87 -- terminating before the first 'Terminator' character. Index will also 88 -- point to the next non blank character. 89 -- The special XML '&' characters are translated appropriately in S. 90 -- S is set to null if Terminator wasn't found in Buf. 91 92 procedure Extract_Attrib 93 (Tag : in out String_Ptr; 94 Attributes : out String_Ptr; 95 Empty_Node : out Boolean); 96 -- Extract the attributes as a string, if the tag contains blanks ' ' 97 -- On return, Tag is unchanged and Attributes contains the string 98 -- If the last character in Tag is '/' then the node is empty and 99 -- Empty_Node is set to True. 100 101 procedure Get_Next_Word 102 (Buf : String; 103 Index : in out Natural; 104 Word : out String_Ptr); 105 -- extract the next textual word from Buf and return it. 106 -- return null if no word left. 107 -- The special XML '&' characters are translated appropriately in S. 108 109 function Translate (S : String) return String; 110 -- Translate S by replacing the XML '&' special characters by the 111 -- actual ASCII character. 112 -- This function currently handles: 113 -- - " 114 -- - > 115 -- - < 116 -- - & 117 -- - ' 118 119 ----------------- 120 -- Skip_Blanks -- 121 ----------------- 122 123 procedure Skip_Blanks (Buf : String; Index : in out Natural) is 124 begin 125 while Index < Buf'Last and then 126 (Buf (Index) = ' ' or else Buf (Index) = ASCII.LF 127 or else Buf (Index) = ASCII.HT 128 or else Buf (Index) = ASCII.CR) 129 loop 130 Index := Index + 1; 131 end loop; 132 end Skip_Blanks; 133 134 ------------- 135 -- Get_Buf -- 136 ------------- 137 138 procedure Get_Buf 139 (Buf : String; 140 Index : in out Natural; 141 Terminator : Character; 142 S : out String_Ptr) 143 is 144 Start : constant Natural := Index; 145 146 begin 147 while Index <= Buf'Last 148 and then Buf (Index) /= Terminator 149 loop 150 Index := Index + 1; 151 end loop; 152 153 if Index > Buf'Last then 154 S := null; 155 156 else 157 S := new String'(Translate (Buf (Start .. Index - 1))); 158 Index := Index + 1; 159 160 if Index < Buf'Last then 161 Skip_Blanks (Buf, Index); 162 end if; 163 end if; 164 end Get_Buf; 165 166 ------------------------ 167 -- Extract_Attributes -- 168 ------------------------ 169 170 procedure Extract_Attrib 171 (Tag : in out String_Ptr; 172 Attributes : out String_Ptr; 173 Empty_Node : out Boolean) 174 is 175 Index : Natural := Tag'First; 176 Index_Last_Of_Tag : Natural; 177 S : String_Ptr; 178 179 begin 180 -- First decide if the node is empty 181 182 if Tag (Tag'Last) = '/' then 183 Empty_Node := True; 184 else 185 Empty_Node := False; 186 end if; 187 188 while Index <= Tag'Last and then 189 not 190 (Tag (Index) = ' ' or else Tag (Index) = ASCII.LF 191 or else Tag (Index) = ASCII.HT 192 or else Tag (Index) = ASCII.CR) 193 loop 194 Index := Index + 1; 195 end loop; 196 197 Index_Last_Of_Tag := Index - 1; 198 Skip_Blanks (Tag.all, Index); 199 200 if Index <= Tag'Last then 201 if Empty_Node then 202 Attributes := new String'(Tag (Index .. Tag'Last - 1)); 203 else 204 Attributes := new String'(Tag (Index .. Tag'Last)); 205 end if; 206 207 S := new String'(Tag (Tag'First .. Index_Last_Of_Tag)); 208 Free (Tag); 209 Tag := S; 210 end if; 211 end Extract_Attrib; 212 213 ------------------- 214 -- Get_Next_Word -- 215 ------------------- 216 217 procedure Get_Next_Word 218 (Buf : String; 219 Index : in out Natural; 220 Word : out String_Ptr) 221 is 222 Terminator : Character; 223 begin 224 Skip_Blanks (Buf, Index); 225 226 if Buf (Index) = ''' or Buf (Index) = '"' then 227 -- If the word starts with a quotation mark, then read until 228 -- the closing mark 229 230 Terminator := Buf (Index); 231 Index := Index + 1; 232 Get_Buf (Buf, Index, Terminator, Word); 233 234 else 235 -- For a normal word, scan up to either a blank, or a '=' 236 237 declare 238 Start_Index : constant Natural := Index; 239 begin 240 while Index <= Buf'Last 241 and then Buf (Index) /= ' ' 242 and then Buf (Index) /= '=' 243 loop 244 Index := Index + 1; 245 end loop; 246 247 Word := new String'(Translate (Buf (Start_Index .. Index - 1))); 248 end; 249 end if; 250 251 if Index < Buf'Last then 252 Skip_Blanks (Buf, Index); 253 end if; 254 end Get_Next_Word; 255 256 --------------- 257 -- Translate -- 258 --------------- 259 260 function Translate (S : String) return String is 261 Str : String (1 .. S'Length); 262 Start, J : Positive; 263 Index : Positive := S'First; 264 In_String : Boolean := False; 265 266 begin 267 if S'Length = 0 then 268 return S; 269 else 270 J := Str'First; 271 272 loop 273 if In_String or else S (Index) /= '&' then 274 Str (J) := S (Index); 275 else 276 Index := Index + 1; 277 Start := Index; 278 279 while S (Index) /= ';' loop 280 Index := Index + 1; 281 pragma Assert (Index <= S'Last); 282 end loop; 283 284 if S (Start .. Index - 1) = "quot" then 285 Str (J) := '"'; 286 elsif S (Start .. Index - 1) = "gt" then 287 Str (J) := '>'; 288 elsif S (Start .. Index - 1) = "lt" then 289 Str (J) := '<'; 290 elsif S (Start .. Index - 1) = "amp" then 291 Str (J) := '&'; 292 elsif S (Start .. Index - 1) = "apos" then 293 Str (J) := '''; 294 end if; 295 end if; 296 297 exit when Index = S'Last; 298 299 if S (Index) = '"' then 300 In_String := not In_String; 301 end if; 302 303 Index := Index + 1; 304 J := J + 1; 305 end loop; 306 307 return Str (1 .. J); 308 end if; 309 end Translate; 310 311 ------------------- 312 -- Get_Attribute -- 313 ------------------- 314 315 function Get_Attribute 316 (N : Node_Ptr; 317 Attribute_Name : UTF8_String; 318 Default : UTF8_String := "") return UTF8_String 319 is 320 Index : Natural; 321 Key, Value : String_Ptr; 322 323 begin 324 if N = null or else N.Attributes = null then 325 return Default; 326 end if; 327 328 Index := N.Attributes'First; 329 while Index < N.Attributes'Last loop 330 Get_Next_Word (N.Attributes.all, Index, Key); 331 Get_Buf (N.Attributes.all, Index, '=', Value); 332 Free (Value); 333 Get_Next_Word (N.Attributes.all, Index, Value); 334 335 if Attribute_Name = Key.all then 336 exit; 337 else 338 Free (Key); 339 Free (Value); 340 end if; 341 end loop; 342 343 Free (Key); 344 345 if Value = null then 346 return Default; 347 else 348 declare 349 V : constant String := Value.all; 350 begin 351 Free (Value); 352 return V; 353 end; 354 end if; 355 end Get_Attribute; 356 357 ------------------- 358 -- Set_Attribute -- 359 ------------------- 360 361 procedure Set_Attribute 362 (N : Node_Ptr; Attribute_Name, Attribute_Value : UTF8_String) 363 is 364 Index, Tmp : Natural; 365 Key, Value : String_Ptr; 366 Atts : String_Ptr; 367 Str : constant String := 368 Attribute_Name & "=""" & Protect (Attribute_Value) & """ "; 369 370 begin 371 if N.Attributes /= null then 372 Index := N.Attributes'First; 373 -- First remove any definition of the attribute in the current list 374 while Index < N.Attributes'Last loop 375 Tmp := Index; 376 Get_Next_Word (N.Attributes.all, Index, Key); 377 Get_Buf (N.Attributes.all, Index, '=', Value); 378 Free (Value); 379 380 Get_Next_Word (N.Attributes.all, Index, Value); 381 Free (Value); 382 383 if Attribute_Name = Key.all then 384 Atts := new String' 385 (Str 386 & N.Attributes (N.Attributes'First .. Tmp - 1) 387 & N.Attributes (Index .. N.Attributes'Last)); 388 Free (N.Attributes); 389 N.Attributes := Atts; 390 Free (Key); 391 return; 392 end if; 393 394 Free (Key); 395 end loop; 396 397 Atts := new String'(Str & N.Attributes.all); 398 Free (N.Attributes); 399 N.Attributes := Atts; 400 401 else 402 N.Attributes := new String'(Str); 403 end if; 404 end Set_Attribute; 405 406 --------------- 407 -- Add_Child -- 408 --------------- 409 410 procedure Add_Child 411 (N : Node_Ptr; Child : Node_Ptr; Append : Boolean := False) 412 is 413 Tmp : Node_Ptr; 414 begin 415 if Append then 416 if N.Child = null then 417 N.Child := Child; 418 else 419 Tmp := N.Child; 420 while Tmp.Next /= null loop 421 Tmp := Tmp.Next; 422 end loop; 423 Tmp.Next := Child; 424 end if; 425 else 426 Child.Next := N.Child; 427 N.Child := Child; 428 end if; 429 Child.Parent := N; 430 end Add_Child; 431 432 -------------- 433 -- Get_Node -- 434 -------------- 435 436 function Get_Node (Buf : String; Index : access Natural) return Node_Ptr is 437 N : constant Node_Ptr := new Node; 438 Q : Node_Ptr; 439 S : String_Ptr; 440 Empty_Node : Boolean; 441 Last_Child : Node_Ptr; 442 443 begin 444 pragma Assert (Buf (Index.all) = '<'); 445 446 Index.all := Index.all + 1; 447 Get_Buf (Buf, Index.all, '>', N.Tag); 448 449 -- Check to see whether it is a comment, !DOCTYPE, or the like: 450 451 if N.Tag (N.Tag'First) = '!' then 452 return Get_Node (Buf, Index); 453 else 454 -- Here we have to deal with the attributes of the form 455 -- <tag attrib='xyyzy'> 456 457 Extract_Attrib (N.Tag, N.Attributes, Empty_Node); 458 459 -- it is possible to have a child-less node that has the form 460 -- <tag /> or <tag attrib='xyyzy'/> 461 462 if Empty_Node then 463 N.Value := new String'(""); 464 else 465 if Buf (Index.all) = '<' then 466 if Buf (Index.all + 1) = '/' then 467 -- No value contained on this node 468 469 N.Value := new String'(""); 470 Index.all := Index.all + 1; 471 472 else 473 -- Parse the children 474 475 Add_Child (N, Get_Node (Buf, Index)); 476 Last_Child := N.Child; 477 pragma Assert (Buf (Index.all) = '<'); 478 479 while Buf (Index.all + 1) /= '/' loop 480 Q := Last_Child; 481 Q.Next := Get_Node (Buf, Index); 482 Q.Next.Parent := N; 483 Last_Child := Q.Next; 484 pragma Assert (Buf (Index.all) = '<'); 485 end loop; 486 487 Index.all := Index.all + 1; 488 end if; 489 490 else 491 -- Get the value of this node 492 493 Get_Buf (Buf, Index.all, '<', N.Value); 494 end if; 495 496 pragma Assert (Buf (Index.all) = '/'); 497 Index.all := Index.all + 1; 498 Get_Buf (Buf, Index.all, '>', S); 499 pragma Assert (N.Tag.all = S.all); 500 Free (S); 501 end if; 502 503 return N; 504 end if; 505 exception 506 when others => 507 return null; 508 end Get_Node; 509 510 ------------- 511 -- Protect -- 512 ------------- 513 514 function Protect (S : String) return String is 515 Length : Natural := 0; 516 Valid_Utf8 : Boolean; 517 Invalid_Pos : Natural; 518 Pos : Natural; 519 520 procedure Update_Length (Idx : Natural); 521 -- Update the final length of the result string 522 523 procedure Translate 524 (Idx : Natural; Res : in out String; Res_Idx : in out Natural); 525 -- Protect an xml-reserved character into its entities equivalence 526 527 ------------------- 528 -- Update_Length -- 529 ------------------- 530 531 procedure Update_Length (Idx : Natural) is 532 begin 533 case S (Idx) is 534 when '<' => Length := Length + 4; 535 when '>' => Length := Length + 4; 536 when '&' => Length := Length + 5; 537 when ''' => Length := Length + 6; 538 when '"' => Length := Length + 6; 539 when others => 540 -- Single case for ascii/utf8: ascii control characters will 541 -- also match. 542 if Unichar_Type (UTF8_Get_Char (S (Idx .. S'Last))) = 543 Unicode_Control 544 then 545 declare 546 Str : constant String := 547 Glib.Gunichar'Image 548 (UTF8_Get_Char (S (Idx .. S'Last))); 549 begin 550 -- Add 2: -1 for the starting space, and +3 for leading 551 -- &# and trailing ; 552 Length := Length + Str'Length + 2; 553 end; 554 elsif Valid_Utf8 then 555 Length := Length + UTF8_Next_Char (S, Idx) - Idx; 556 else 557 Length := Length + 1; 558 end if; 559 end case; 560 end Update_Length; 561 562 --------------- 563 -- Translate -- 564 --------------- 565 566 procedure Translate 567 (Idx : Natural; Res : in out String; Res_Idx : in out Natural) is 568 begin 569 case S (Idx) is 570 when '<' => 571 Res (Res_Idx .. Res_Idx + 3) := "<"; 572 Res_Idx := Res_Idx + 4; 573 when '>' => 574 Res (Res_Idx .. Res_Idx + 3) := ">"; 575 Res_Idx := Res_Idx + 4; 576 when '&' => 577 Res (Res_Idx .. Res_Idx + 4) := "&"; 578 Res_Idx := Res_Idx + 5; 579 when ''' => 580 Res (Res_Idx .. Res_Idx + 5) := "'"; 581 Res_Idx := Res_Idx + 6; 582 when '"' => 583 Res (Res_Idx .. Res_Idx + 5) := """; 584 Res_Idx := Res_Idx + 6; 585 when others => 586 declare 587 Char : constant Glib.Gunichar := 588 UTF8_Get_Char (S (Idx .. S'Last)); 589 Next : Natural; 590 begin 591 if Unichar_Type (Char) = Unicode_Control then 592 declare 593 Str : constant String := Glib.Gunichar'Image (Char); 594 begin 595 Res (Res_Idx .. Res_Idx + Str'Length + 1) := 596 "&#" & Str (Str'First + 1 .. Str'Last) & ";"; 597 Res_Idx := Res_Idx + Str'Length + 2; 598 end; 599 600 elsif Valid_Utf8 then 601 Next := UTF8_Next_Char (S, Idx); 602 Res (Res_Idx .. Res_Idx + Next - Idx - 1) := 603 S (Idx .. Next - 1); 604 Res_Idx := Res_Idx + Next - Idx; 605 606 else 607 Res (Res_Idx) := S (Idx); 608 Res_Idx := Res_Idx + 1; 609 end if; 610 end; 611 end case; 612 end Translate; 613 614 begin 615 UTF8_Validate (S, Valid_Utf8, Invalid_Pos); 616 617 if Valid_Utf8 then 618 Pos := S'First; 619 620 while Pos <= S'Last loop 621 Update_Length (Pos); 622 Pos := UTF8_Next_Char (S, Pos); 623 end loop; 624 625 else 626 for J in S'Range loop 627 Update_Length (J); 628 end loop; 629 end if; 630 631 declare 632 Result : String (1 .. Length); 633 Index : Integer := 1; 634 635 begin 636 if Valid_Utf8 then 637 Pos := S'First; 638 639 while Pos <= S'Last loop 640 Translate (Pos, Result, Index); 641 Pos := UTF8_Next_Char (S, Pos); 642 end loop; 643 644 else 645 for J in S'Range loop 646 Translate (J, Result, Index); 647 end loop; 648 end if; 649 650 return Result; 651 end; 652 end Protect; 653 654 ----------- 655 -- Print -- 656 ----------- 657 658 procedure Print (N : Node_Ptr; File_Name : String := "") is 659 Success : Boolean; 660 pragma Unreferenced (Success); 661 begin 662 Print (N, File_Name, Success); 663 end Print; 664 665 ----------- 666 -- Print -- 667 ----------- 668 669 procedure Print 670 (N : Node_Ptr; 671 File_Name : String; 672 Success : out Boolean) 673 is 674 File : Integer := 1; 675 676 procedure Do_Indent (Indent : Natural); 677 -- Print a string made of Indent blank characters. 678 679 procedure Print_String (S : String); 680 -- Print S to File, after replacing the special '<', '>', 681 -- '"', '&' and ''' characters. 682 683 procedure Print_Node (N : Node_Ptr; Indent : Natural); 684 -- Write a node and its children to File 685 686 procedure Put (S : String); 687 -- Write S to File 688 689 procedure Put_Line (S : String); 690 -- Write S & LF to File 691 692 --------- 693 -- Put -- 694 --------- 695 696 procedure Put (S : String) is 697 begin 698 Write (File, S, S'Length); 699 end Put; 700 701 -------------- 702 -- Put_Line -- 703 -------------- 704 705 procedure Put_Line (S : String) is 706 begin 707 Put (S & ASCII.LF); 708 end Put_Line; 709 710 --------------- 711 -- Do_Indent -- 712 --------------- 713 714 procedure Do_Indent (Indent : Natural) is 715 begin 716 Put ((1 .. Indent => ' ')); 717 end Do_Indent; 718 719 ------------------ 720 -- Print_String -- 721 ------------------ 722 723 procedure Print_String (S : String) is 724 begin 725 for J in S'Range loop 726 case S (J) is 727 when '<' => Put ("<"); 728 when '>' => Put (">"); 729 when '&' => Put ("&"); 730 when ''' => Put ("'"); 731 when '"' => Put ("""); 732 when ASCII.NUL .. Character'Val (9) 733 | Character'Val (11) .. Character'Val (31) => 734 declare 735 Img : constant String := 736 Integer'Image (Character'Pos (S (J))); 737 begin 738 Put ("&#" & Img (Img'First + 1 .. Img'Last) & ";"); 739 end; 740 when others => Put ((1 => S (J))); 741 end case; 742 end loop; 743 end Print_String; 744 745 ---------------- 746 -- Print_Node -- 747 ---------------- 748 749 procedure Print_Node (N : Node_Ptr; Indent : Natural) is 750 P : Node_Ptr; 751 begin 752 Do_Indent (Indent); 753 Put ("<" & N.Tag.all); 754 755 if N.Attributes /= null then 756 Put (" " & N.Attributes.all); 757 end if; 758 759 if N.Child /= null then 760 Put_Line (">"); 761 P := N.Child; 762 while P /= null loop 763 Print_Node (P, Indent + 2); 764 P := P.Next; 765 end loop; 766 767 Do_Indent (Indent); 768 Put_Line ("</" & N.Tag.all & ">"); 769 770 elsif N.Value = null 771 or else N.Value.all = "" 772 then 773 -- The following handles the difference between what you got 774 -- when you parsed <tag/> vs. <tag />. 775 if N.Tag (N.Tag'Last) = '/' then 776 Put_Line (">"); 777 else 778 Put_Line (" />"); 779 end if; 780 else 781 Put (">"); 782 Print_String (N.Value.all); 783 Put_Line ("</" & N.Tag.all & ">"); 784 end if; 785 end Print_Node; 786 787 begin 788 if File_Name /= "" then 789 File := Create_File (File_Name & ASCII.NUL); 790 791 if File < 0 then 792 Success := False; 793 return; 794 end if; 795 end if; 796 797 Put_Line ("<?xml version=""1.0""?>"); 798 Print_Node (N, 0); 799 800 if File_Name /= "" then 801 Close (File); 802 end if; 803 804 Success := True; 805 end Print; 806 807 ----------- 808 -- Parse -- 809 ----------- 810 811 function Parse (File : String) return Node_Ptr is 812 813 function Read_File (The_File : String) return String_Ptr; 814 -- Return the contents of an entire file. 815 -- If the file cannot be found, return null. 816 -- The caller is responsible for freeing the returned memory. 817 818 --------------- 819 -- Read_File -- 820 --------------- 821 822 function Read_File (The_File : String) return String_Ptr is 823 FD : Integer; 824 Buffer : String_Ptr; 825 Length : Integer; 826 pragma Warnings (Off, Length); 827 828 begin 829 FD := Open_Read (The_File & ASCII.NUL); 830 831 if FD < 0 then 832 return null; 833 end if; 834 835 Length := Integer (File_Length (FD)); 836 Buffer := new String (1 .. Length); 837 Length := Read (FD, Buffer.all'Address, Length); 838 Close (FD); 839 return Buffer; 840 end Read_File; 841 842 Buf : String_Ptr; 843 Result : Node_Ptr; 844 845 begin 846 Buf := Read_File (File); 847 848 if Buf = null then 849 return null; 850 end if; 851 852 Result := Parse_Buffer (Buf.all); 853 Free (Buf); 854 return Result; 855 end Parse; 856 857 ------------------ 858 -- Parse_Buffer -- 859 ------------------ 860 861 function Parse_Buffer (Buffer : UTF8_String) return Node_Ptr is 862 Index : aliased Natural := 2; 863 XML_Version : String_Ptr; 864 Encoding : Integer; 865 Encoding_Last : Integer; 866 Result : Node_Ptr; 867 begin 868 Get_Buf (Buffer, Index, '>', XML_Version); 869 if XML_Version = null then 870 return null; 871 else 872 -- Check the encoding specified for that file 873 Encoding := Ada.Strings.Fixed.Index (XML_Version.all, "encoding"); 874 875 if Encoding /= 0 then 876 while Encoding <= XML_Version'Last 877 and then XML_Version (Encoding) /= '"' 878 loop 879 Encoding := Encoding + 1; 880 end loop; 881 882 Encoding := Encoding + 1; 883 Encoding_Last := Encoding + 1; 884 885 while Encoding_Last <= XML_Version'Last 886 and then XML_Version (Encoding_Last) /= '"' 887 loop 888 Encoding_Last := Encoding_Last + 1; 889 end loop; 890 891 if Encoding_Last <= XML_Version'Last then 892 declare 893 Error : aliased GError; 894 Utf8_Buffer : constant String := Glib.Convert.Convert 895 (Buffer, 896 To_Codeset => "UTF-8", 897 From_Codeset => 898 XML_Version (Encoding .. Encoding_Last - 1), 899 Error => Error'Unchecked_Access); 900 begin 901 if Utf8_Buffer /= "" then 902 Result := Get_Node (Utf8_Buffer, Index'Unchecked_Access); 903 else 904 Glib.Messages.Log 905 ("Glib", Log_Level_Warning, Get_Message (Error)); 906 Error_Free (Error); 907 end if; 908 end; 909 else 910 Result := Get_Node (Buffer, Index'Unchecked_Access); 911 end if; 912 else 913 Result := Get_Node (Buffer, Index'Unchecked_Access); 914 end if; 915 916 Free (XML_Version); 917 return Result; 918 end if; 919 end Parse_Buffer; 920 921 -------------- 922 -- Find_Tag -- 923 -------------- 924 925 function Find_Tag (N : Node_Ptr; Tag : UTF8_String) return Node_Ptr is 926 P : Node_Ptr := N; 927 928 begin 929 while P /= null loop 930 if P.Tag.all = Tag then 931 return P; 932 end if; 933 934 P := P.Next; 935 end loop; 936 937 return null; 938 end Find_Tag; 939 940 ----------------------------- 941 -- Find_Tag_With_Attribute -- 942 ----------------------------- 943 944 function Find_Tag_With_Attribute 945 (N : Node_Ptr; 946 Tag : UTF8_String; 947 Key : UTF8_String; 948 Value : UTF8_String := "") return Node_Ptr 949 is 950 P : Node_Ptr := N; 951 begin 952 while P /= null loop 953 if P.Tag.all = Tag then 954 declare 955 The_Value : constant String := Get_Attribute (P, Key); 956 begin 957 if The_Value /= "" then 958 if Value = "" or The_Value = Value then 959 -- if Value is not given when calling the 960 -- the function only the Key need to match 961 return P; 962 end if; 963 end if; 964 end; 965 end if; 966 P := P.Next; 967 end loop; 968 969 return null; 970 end Find_Tag_With_Attribute; 971 972 --------------- 973 -- Get_Field -- 974 --------------- 975 976 function Get_Field (N : Node_Ptr; Field : UTF8_String) return String_Ptr is 977 P : constant Node_Ptr := Find_Tag (N.Child, Field); 978 979 begin 980 if P /= null then 981 return P.Value; 982 else 983 return null; 984 end if; 985 end Get_Field; 986 987 ---------- 988 -- Free -- 989 ---------- 990 991 procedure Free 992 (N : in out Node_Ptr; Free_Data : Free_Specific_Data := null) 993 is 994 procedure Free_Node (N : in out Node_Ptr); 995 -- Free the memory for a node, but doesn't remove it from its parent 996 997 procedure Unchecked_Free is new Unchecked_Deallocation (Node, Node_Ptr); 998 999 --------------- 1000 -- Free_Node -- 1001 --------------- 1002 1003 procedure Free_Node (N : in out Node_Ptr) is 1004 Child : Node_Ptr := N.Child; 1005 Next : Node_Ptr; 1006 1007 begin 1008 Free (N.Tag); 1009 Free (N.Attributes); 1010 Free (N.Value); 1011 1012 if Free_Data /= null then 1013 Free_Data (N.Specific_Data); 1014 end if; 1015 1016 -- Free all the children 1017 while Child /= null loop 1018 Next := Child.Next; 1019 Free_Node (Child); 1020 Child := Next; 1021 end loop; 1022 1023 Unchecked_Free (N); 1024 end Free_Node; 1025 1026 Child : Node_Ptr; 1027 Previous : Node_Ptr; 1028 1029 begin 1030 if N = null then 1031 return; 1032 end if; 1033 1034 if N.Parent /= null then 1035 Child := N.Parent.Child; 1036 1037 -- Remove the node from its parent 1038 while Child /= null and then Child /= N loop 1039 Previous := Child; 1040 Child := Child.Next; 1041 end loop; 1042 1043 if Child = N then 1044 if Previous = null then 1045 N.Parent.Child := N.Next; 1046 else 1047 Previous.Next := N.Next; 1048 end if; 1049 end if; 1050 end if; 1051 1052 -- Free the memory occupied by the node 1053 Free_Node (N); 1054 end Free; 1055 1056 --------------- 1057 -- Deep_Copy -- 1058 --------------- 1059 1060 function Deep_Copy (N : Node_Ptr) return Node_Ptr is 1061 function Deep_Copy_Internal 1062 (N : Node_Ptr; Parent : Node_Ptr := null) return Node_Ptr; 1063 -- Internal version of Deep_Copy. Returns a deep copy of N, whose 1064 -- parent should be Parent. 1065 1066 function Deep_Copy_Internal 1067 (N : Node_Ptr; Parent : Node_Ptr := null) return Node_Ptr 1068 is 1069 Attr : String_Ptr; 1070 Value : String_Ptr; 1071 1072 New_N : Node_Ptr; 1073 Child : Node_Ptr; 1074 N_Child : Node_Ptr; 1075 begin 1076 if N = null then 1077 return null; 1078 else 1079 if N.Attributes /= null then 1080 Attr := new String'(N.Attributes.all); 1081 end if; 1082 1083 if N.Value /= null then 1084 Value := new String'(N.Value.all); 1085 end if; 1086 1087 -- Do not clone Next: For the initial node, we should not clone 1088 -- the next nodes, only its children. And for children this is 1089 -- done by Deep_Copy_Internal on the parent 1090 1091 New_N := new Node' 1092 (Tag => new String'(N.Tag.all), 1093 Attributes => Attr, 1094 Value => Value, 1095 Parent => Parent, 1096 Child => null, 1097 Next => null, 1098 Specific_Data => N.Specific_Data); 1099 1100 -- Clone each child 1101 1102 Child := N.Child; 1103 while Child /= null loop 1104 if N_Child = null then 1105 New_N.Child := Deep_Copy_Internal (Child, Parent => New_N); 1106 N_Child := New_N.Child; 1107 else 1108 N_Child.Next := Deep_Copy_Internal (Child, Parent => New_N); 1109 N_Child := N_Child.Next; 1110 end if; 1111 Child := Child.Next; 1112 end loop; 1113 1114 return New_N; 1115 end if; 1116 end Deep_Copy_Internal; 1117 1118 begin 1119 return Deep_Copy_Internal (N); 1120 end Deep_Copy; 1121 1122 -------------- 1123 -- Is_Equal -- 1124 -------------- 1125 1126 function Is_Equal (Node1, Node2 : Node_Ptr) return Boolean is 1127 begin 1128 if Node1 = null then 1129 if Node2 /= null then 1130 return False; 1131 else 1132 return True; 1133 end if; 1134 elsif Node2 = null then 1135 return False; 1136 end if; 1137 1138 if Node1.Tag = null then 1139 if Node2.Tag /= null then 1140 return False; 1141 end if; 1142 elsif Node2.Tag = null then 1143 return False; 1144 elsif Node1.Tag.all /= Node2.Tag.all then 1145 return False; 1146 end if; 1147 1148 if Node1.Attributes = null then 1149 if Node2.Attributes /= null then 1150 return False; 1151 end if; 1152 elsif Node2.Attributes = null then 1153 return False; 1154 elsif Node1.Attributes.all /= Node2.Attributes.all then 1155 return False; 1156 end if; 1157 1158 if Node1.Value = null then 1159 if Node2.Value /= null then 1160 return False; 1161 end if; 1162 elsif Node2.Value = null then 1163 return False; 1164 elsif Node1.Value.all /= Node2.Value.all then 1165 return False; 1166 end if; 1167 1168 if Node1.Child = null then 1169 if Node2.Child /= null then 1170 return False; 1171 end if; 1172 elsif Node2.Child = null then 1173 return False; 1174 elsif not Is_Equal (Node1.Child, Node2.Child) then 1175 return False; 1176 end if; 1177 1178 if Node1.Next = null then 1179 if Node2.Next /= null then 1180 return False; 1181 end if; 1182 elsif Node2.Next = null then 1183 return False; 1184 elsif not Is_Equal (Node1.Next, Node2.Next) then 1185 return False; 1186 end if; 1187 return True; 1188 end Is_Equal; 1189 1190 -------------------- 1191 -- Children_Count -- 1192 -------------------- 1193 1194 function Children_Count (N : Node_Ptr) return Natural is 1195 Tmp : Node_Ptr; 1196 Count : Natural := 0; 1197 begin 1198 if N /= null then 1199 Tmp := N.Child; 1200 while Tmp /= null loop 1201 Count := Count + 1; 1202 Tmp := Tmp.Next; 1203 end loop; 1204 end if; 1205 return Count; 1206 end Children_Count; 1207 1208end Glib.XML; 1209