------------------------------------------------------------------------------ -- XML/Ada - An XML suite for Ada95 -- -- -- -- Copyright (C) 2001-2022, AdaCore -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; use Ada.Text_IO; with Ada.Text_IO.Text_Streams; with Unicode; use Unicode; with Unicode.CES; use Unicode.CES; with Unicode.Names.Basic_Latin; use Unicode.Names.Basic_Latin; with Sax.Encodings; use Sax.Encodings; with Sax.Symbols; use Sax.Symbols; with Sax.Utils; use Sax.Utils; with Unicode.Encodings; use Unicode.Encodings; package body DOM.Core.Nodes is procedure Print_String (Stream : access Ada.Streams.Root_Stream_Type'Class; Str : DOM_String; EOL_Sequence : String; Encoding : Unicode.Encodings.Unicode_Encoding); -- Print a string on standard output, in XML, protecting special -- characters. -- Str is encoded in Unicode/Sax.Encodings.Encoding, and the output is done -- with Encoding procedure Put (Stream : access Ada.Streams.Root_Stream_Type'Class; Str : DOM_String; Encoding : Unicode_Encoding); -- Print Str, but doesn't protect any special character in it procedure Print_Name (Stream : access Ada.Streams.Root_Stream_Type'Class; N : Node; With_URI : Boolean; EOL_Sequence : String; Encoding : Unicode.Encodings.Unicode_Encoding); -- Print the name of the node. procedure Free (List : in out Node_List; Deep : Boolean); -- Free the list, and, if Deep is True, all its children function Child_Is_Valid (Parent : Node; Child : Node) return Boolean; -- Return True if Child can be added to Parent procedure Sort (Map : in out Named_Node_Map); -- Sort alphabetically the contents of Map (this is based on the value -- of Node_Name). function Namespace_URI (N : Node) return Symbol; -- Internal version returning symbols -------------------- -- Child_Is_Valid -- -------------------- function Child_Is_Valid (Parent : Node; Child : Node) return Boolean is begin case Parent.Node_Type is when Attribute_Node => return Child.Node_Type = Text_Node or else Child.Node_Type = Entity_Reference_Node; when Text_Node | Cdata_Section_Node | Processing_Instruction_Node | Comment_Node | Document_Type_Node | Notation_Node => return False; when Entity_Reference_Node | Entity_Node | Element_Node | Document_Fragment_Node => return Child.Node_Type = Element_Node or else Child.Node_Type = Processing_Instruction_Node or else Child.Node_Type = Comment_Node or else Child.Node_Type = Text_Node or else Child.Node_Type = Cdata_Section_Node or else Child.Node_Type = Entity_Reference_Node; when Document_Node => -- ??? Should check there is one single Element_Node return Child.Node_Type = Processing_Instruction_Node or else Child.Node_Type = Comment_Node or else Child.Node_Type = Document_Type_Node or else Child.Node_Type = Element_Node; end case; end Child_Is_Valid; --------------- -- Node_Name -- --------------- function Node_Name (N : Node) return DOM_String is begin case N.Node_Type is when Element_Node => return Qualified_Name (N.Name); when Attribute_Node => return Qualified_Name (N.Attr_Name); when Text_Node => -- ??? Should this return an encoded string instead ? return "#text"; when Cdata_Section_Node => return "#cdata-section"; when Entity_Reference_Node => pragma Assert (N.Entity_Reference_Name /= No_Symbol); return Get (N.Entity_Reference_Name).all; when Entity_Node => pragma Assert (N.Entity_Name /= No_Symbol); return Get (N.Entity_Name).all; when Processing_Instruction_Node => pragma Assert (N.Target /= No_Symbol); return Get (N.Target).all; when Comment_Node => return "#comment"; when Document_Node => return "#document"; when Document_Type_Node => pragma Assert (N.Document_Type_Name /= null); return N.Document_Type_Name.all; when Document_Fragment_Node => return "document-fragment"; when Notation_Node => pragma Assert (N.Public_ID /= null); return N.Public_ID.all; end case; end Node_Name; ---------------- -- Node_Value -- ---------------- function Node_Value (N : Node) return DOM_String is begin case N.Node_Type is when Attribute_Node => pragma Assert (N.Attr_Value /= No_Symbol); return Get (N.Attr_Value).all; when Text_Node => pragma Assert (N.Text /= null); return N.Text.all; when Cdata_Section_Node => pragma Assert (N.Cdata /= null); return N.Cdata.all; when Processing_Instruction_Node => pragma Assert (N.Pi_Data /= No_Symbol); return Get (N.Pi_Data).all; when Comment_Node => pragma Assert (N.Comment /= null); return N.Comment.all; when others => return ""; end case; end Node_Value; -------------------- -- Set_Node_Value -- -------------------- procedure Set_Node_Value (N : Node; Value : DOM_String) is begin case N.Node_Type is when Attribute_Node => -- ??? If Specified is False, we should make a copy and assign -- it to the owner element N.Attr_Value := Find (Owner_Document (N).Symbols, Value); N.Specified := True; when Text_Node => Free (N.Text); N.Text := new DOM_String'(Value); when Cdata_Section_Node => Free (N.Cdata); N.Cdata := new DOM_String'(Value); when Processing_Instruction_Node => N.Pi_Data := Find (Owner_Document (N).Symbols, Value); when Comment_Node => Free (N.Comment); N.Comment := new DOM_String'(Value); when others => null; end case; end Set_Node_Value; ----------------- -- Child_Nodes -- ----------------- function Child_Nodes (N : Node) return Node_List is begin case N.Node_Type is when Element_Node => return N.Children; when Document_Node => return N.Doc_Children; when Document_Type_Node => return N.Doc_Type_Children; when Document_Fragment_Node => return N.Doc_Frag_Children; when Entity_Reference_Node => -- ??? Should return the expansion of the entity itself return Null_List; when others => return Null_List; end case; end Child_Nodes; ----------------- -- First_Child -- ----------------- function First_Child (N : Node) return Node is List : constant Node_List := Child_Nodes (N); begin if List.Items = null or else List.Last < 0 then return null; else return List.Items (0); end if; end First_Child; ---------------- -- Last_Child -- ---------------- function Last_Child (N : Node) return Node is List : constant Node_List := Child_Nodes (N); begin if List.Items = null or else List.Last < 0 then return null; else return List.Items (List.Last); end if; end Last_Child; ---------------------- -- Previous_Sibling -- ---------------------- function Previous_Sibling (N : Node) return Node is List : Node_List; begin if N.Parent = null or else N.Parent_Is_Owner or else N.Node_Type = Attribute_Node then return null; end if; List := Child_Nodes (N.Parent); for J in 1 .. List.Last loop if List.Items (J) = N then return List.Items (J - 1); end if; end loop; return null; end Previous_Sibling; ------------------ -- Next_Sibling -- ------------------ function Next_Sibling (N : Node) return Node is List : Node_List; begin if N.Parent = null or else N.Parent_Is_Owner or else N.Node_Type = Attribute_Node then return null; end if; List := Child_Nodes (N.Parent); for J in 0 .. List.Last - 1 loop if List.Items (J) = N then return List.Items (J + 1); end if; end loop; return null; end Next_Sibling; --------------- -- Node_Type -- --------------- function Node_Type (N : Node) return Node_Types is begin return N.Node_Type; end Node_Type; ----------------- -- Parent_Node -- ----------------- function Parent_Node (N : Node) return Node is begin if N.Node_Type = Attribute_Node or else N.Parent_Is_Owner then return null; else return N.Parent; end if; end Parent_Node; ---------------- -- Attributes -- ---------------- function Attributes (N : Node) return Named_Node_Map is begin case N.Node_Type is when Element_Node => return N.Attributes; when others => return Null_Node_Map; end case; end Attributes; -------------------- -- Owner_Document -- -------------------- function Owner_Document (N : Node) return Node is P : Node := N; begin if N.Parent_Is_Owner then return N.Parent; else while P /= null and then P.Node_Type /= Document_Node loop P := P.Parent; end loop; return P; end if; end Owner_Document; ------------------- -- Namespace_URI -- ------------------- function Namespace_URI (N : Node) return DOM_String is begin return Get (Namespace_URI (N)).all; end Namespace_URI; ------------------- -- Namespace_URI -- ------------------- function Namespace_URI (N : Node) return Symbol is begin case N.Node_Type is when Element_Node => if N.Name.Namespace = No_Symbol then return Empty_String; else return N.Name.Namespace; end if; when Attribute_Node => if N.Attr_Name.Namespace = No_Symbol then return Empty_String; else return N.Attr_Name.Namespace; end if; when others => return Empty_String; end case; end Namespace_URI; ------------ -- Prefix -- ------------ function Prefix (N : Node) return DOM_String is begin case N.Node_Type is when Element_Node => if N.Name.Prefix = No_Symbol then return ""; else return Get (N.Name.Prefix).all; end if; when Attribute_Node => if N.Attr_Name.Prefix = No_Symbol then return ""; else return Get (N.Attr_Name.Prefix).all; end if; when others => return ""; end case; end Prefix; ---------------- -- Set_Prefix -- ---------------- procedure Set_Prefix (N : Node; Prefix : DOM_String) is Doc : constant Document := Owner_Document (N); begin if Doc = null then Put_Line ("Set_Prefix only works when the node is part of a" & " tree already"); return; end if; case N.Node_Type is when Element_Node => N.Name.Prefix := Find (Doc.Symbols, Prefix); when Attribute_Node => N.Attr_Name.Prefix := Find (Doc.Symbols, Prefix); when others => null; end case; end Set_Prefix; ---------------- -- Local_Name -- ---------------- function Local_Name (N : Node) return DOM_String is begin case N.Node_Type is when Element_Node => return Get (N.Name.Local_Name).all; when Attribute_Node => return Get (N.Attr_Name.Local_Name).all; when others => return ""; end case; end Local_Name; ---------------- -- Local_Name -- ---------------- function Local_Name (N : Node) return Sax.Symbols.Symbol is begin case N.Node_Type is when Element_Node => return N.Name.Local_Name; when Attribute_Node => return N.Attr_Name.Local_Name; when others => return Empty_String; end case; end Local_Name; ------------------- -- Insert_Before -- ------------------- function Insert_Before (N : Node; New_Child : Node; Ref_Child : Node := null) return Node is procedure Insert_Before (List : in out Node_List); -- Insert New_Child before Ref_Child in List procedure Insert_Before (List : in out Node_List) is Old : Node_Array_Access := List.Items; begin for J in 0 .. List.Last loop if List.Items (J) = Ref_Child then if List.Items'Last = List.Last then List.Items := new Node_Array (0 .. List.Last + 5); List.Items (0 .. List.Last) := Old.all; Free (Old); end if; List.Items (0 .. List.Last + 1) := List.Items (0 .. J - 1) & New_Child & List.Items (J .. List.Last); List.Last := List.Last + 1; return; end if; end loop; end Insert_Before; Tmp : Node; pragma Unreferenced (Tmp); begin pragma Assert (Child_Is_Valid (N, New_Child)); if Owner_Document (N) /= Owner_Document (New_Child) then raise Wrong_Document_Err; end if; -- If New_Child is already in the tree, remove it first if New_Child.Parent /= null and then not New_Child.Parent_Is_Owner then Tmp := Remove_Child (New_Child.Parent, New_Child); end if; -- Ref_Child must be a child of N if Ref_Child /= null and then Ref_Child.Parent /= N then raise Not_Found_Err; end if; -- ??? if New_Child is Document_Fragment_Node, insert all its children if Ref_Child = null then case N.Node_Type is when Element_Node => Append (N.Children, New_Child); when Document_Node => Append (N.Doc_Children, New_Child); when Document_Type_Node => Append (N.Doc_Type_Children, New_Child); when Document_Fragment_Node => Append (N.Doc_Frag_Children, New_Child); when others => raise Hierarchy_Request_Err; end case; else case N.Node_Type is when Element_Node => Insert_Before (N.Children); when Document_Node => Insert_Before (N.Doc_Children); when Document_Type_Node => Insert_Before (N.Doc_Type_Children); when Document_Fragment_Node => Insert_Before (N.Doc_Frag_Children); when others => raise Hierarchy_Request_Err; end case; end if; New_Child.Parent := N; New_Child.Parent_Is_Owner := False; return New_Child; end Insert_Before; ------------------- -- Replace_Child -- ------------------- function Replace_Child (N : Node; New_Child : Node; Old_Child : Node) return Node is List : constant Node_List := Child_Nodes (N); begin pragma Assert (Child_Is_Valid (N, New_Child)); -- ??? Case where New_Child is a document_fragment if Owner_Document (N) /= Owner_Document (New_Child) then raise Wrong_Document_Err; end if; for J in 0 .. List.Last loop if List.Items (J) = Old_Child then List.Items (J) := New_Child; New_Child.Parent := N; New_Child.Parent_Is_Owner := False; return Old_Child; end if; end loop; return null; end Replace_Child; ------------------ -- Remove_Child -- ------------------ function Remove_Child (N : Node; Old_Child : Node) return Node is Document : constant Node := Owner_Document (Old_Child); Success : Boolean := False; begin case N.Node_Type is when Element_Node => Remove (N.Children, Old_Child, Success); when Document_Node => Remove (N.Doc_Children, Old_Child, Success); when Document_Type_Node => return null; when Document_Fragment_Node => Remove (N.Doc_Frag_Children, Old_Child, Success); when others => return null; end case; if Success then Old_Child.Parent_Is_Owner := True; Old_Child.Parent := Document; return Old_Child; else raise Not_Found_Err; end if; end Remove_Child; ------------------ -- Append_Child -- ------------------ function Append_Child (N : Node; New_Child : Node) return Node is begin return Insert_Before (N, New_Child, null); end Append_Child; --------------------- -- Has_Child_Nodes -- --------------------- function Has_Child_Nodes (N : Node) return Boolean is begin return First_Child (N) /= null; end Has_Child_Nodes; ---------------- -- Clone_Node -- ---------------- function Clone_Node (N : Node; Deep : Boolean) return Node is Clone : Node; ---------------- -- Clone_List -- ---------------- function Clone_List (List : Node_List; Deep : Boolean; Owner : Node := null) return Node_List; -- Return a clone of List. If Deep is True, then each item in the list -- is also cloned ---------------- -- Clone_List -- ---------------- function Clone_List (List : Node_List; Deep : Boolean; Owner : Node := null) return Node_List is L : Node_List := Null_List; begin if List /= Null_List and then Deep then L := (Items => new Node_Array (List.Items'First .. List.Last), Last => List.Last); for J in L.Items'First .. L.Last loop L.Items (J) := Clone_Node (List.Items (J), Deep); L.Items (J).Parent := Clone; L.Items (J).Parent_Is_Owner := False; if Owner /= null then L.Items (J).Owner_Element := Owner; end if; end loop; end if; return L; end Clone_List; begin Clone := new Node_Record (N.Node_Type); Clone.Parent := Owner_Document (N); Clone.Parent_Is_Owner := True; case N.Node_Type is when Element_Node => Clone.Name := N.Name; Clone.Children := Clone_List (N.Children, Deep); Clone.Attributes := Named_Node_Map (Clone_List (Node_List (N.Attributes), True, Clone)); when Attribute_Node => Clone.Attr_Name := N.Attr_Name; Clone.Attr_Value := N.Attr_Value; Clone.Specified := N.Specified; Clone.Is_Id := N.Is_Id; when Text_Node => if N.Text /= null then Clone.Text := new DOM_String'(N.Text.all); end if; when Cdata_Section_Node => if N.Cdata /= null then Clone.Cdata := new DOM_String'(N.Cdata.all); end if; when Entity_Reference_Node => Clone.Entity_Reference_Name := N.Entity_Reference_Name; when Entity_Node => Clone.Entity_Name := N.Entity_Name; when Processing_Instruction_Node => Clone.Target := N.Target; Clone.Pi_Data := N.Pi_Data; when Comment_Node => pragma Assert (N.Comment /= null); Clone.Comment := new DOM_String'(N.Comment.all); when Document_Node => Clone.Doc_Children := Clone_List (N.Doc_Children, Deep); when Document_Type_Node => Clone.Document_Type_Name := new DOM_String'(N.Document_Type_Name.all); Clone.Doc_Type_Children := Clone_List (N.Doc_Type_Children, Deep); when Document_Fragment_Node => Clone.Doc_Frag_Children := Clone_List (N.Doc_Frag_Children, Deep); when Notation_Node => if N.Public_ID /= null then Clone.Public_ID := new DOM_String'(N.Public_ID.all); end if; if N.System_ID /= null then Clone.System_ID := new DOM_String'(N.System_ID.all); end if; end case; return Clone; end Clone_Node; --------------- -- Normalize -- --------------- procedure Normalize (N : Node) is List : Node_List := Child_Nodes (N); J : Natural := 0; Old : DOM_String_Access; L1, L2 : Integer; begin while J < List.Last loop if List.Items (J).Node_Type = Text_Node and then List.Items (J + 1).Node_Type = Text_Node then Old := List.Items (J).Text; L1 := Old.all'Length; L2 := List.Items (J + 1).Text.all'Length; List.Items (J).Text := new DOM_String (1 .. L1 + L2); List.Items (J).Text (1 .. L1) := Old.all; List.Items (J).Text (L1 + 1 .. L1 + L2) := List.Items (J + 1).Text.all; Free (List.Items (J + 1)); Free (Old); List.Items (J + 1 .. List.Last - 1) := List.Items (J + 2 .. List.Last); List.Last := List.Last - 1; else J := J + 1; end if; end loop; case N.Node_Type is when Element_Node => N.Children := List; when Document_Node => N.Doc_Children := List; when Document_Type_Node => N.Doc_Type_Children := List; when Document_Fragment_Node => N.Doc_Frag_Children := List; when others => null; end case; -- Normalize all the children J := 0; while J <= List.Last loop Normalize (List.Items (J)); J := J + 1; end loop; end Normalize; -------------- -- Supports -- -------------- function Supports (N : Node; Feature : DOM_String; Version : DOM_String) return Boolean is pragma Warnings (Off, N); pragma Warnings (Off, Feature); pragma Warnings (Off, Version); begin return False; end Supports; ---------- -- Item -- ---------- function Item (List : Node_List; Index : Natural) return Node is begin if Index <= List.Last then return List.Items (Index); else return null; end if; end Item; ------------ -- Length -- ------------ function Length (List : Node_List) return Natural is begin return List.Last + 1; end Length; -------------------- -- Get_Named_Item -- -------------------- function Get_Named_Item (Map : Named_Node_Map; Name : DOM_String) return Node is begin for J in 0 .. Map.Last loop if Node_Name (Map.Items (J)) = Name then return Map.Items (J); end if; end loop; return null; end Get_Named_Item; -------------------- -- Get_Named_Item -- -------------------- function Get_Named_Item (Map : Named_Node_Map; Name : Sax.Symbols.Symbol) return Node is begin for J in 0 .. Map.Last loop if Namespace_URI (Map.Items (J)) = Empty_String and then Local_Name (Map.Items (J)) = Name then return Map.Items (J); end if; end loop; return null; end Get_Named_Item; -------------------- -- Set_Named_Item -- -------------------- procedure Set_Named_Item (Map : in out Named_Node_Map; Arg : Node; Replaces : out Node) is begin Remove_Named_Item (Map, Node_Name (Arg), Replaces); Append (Node_List (Map), Arg); end Set_Named_Item; -------------------- -- Set_Named_Item -- -------------------- procedure Set_Named_Item (Map : in out Named_Node_Map; Arg : Node) is Replaces : Node; begin Set_Named_Item (Map, Arg, Replaces); end Set_Named_Item; ----------------------- -- Remove_Named_Item -- ----------------------- procedure Remove_Named_Item (Map : in out Named_Node_Map; N : Node) is begin for J in 0 .. Map.Last loop if Map.Items (J) = N then Map.Items (J .. Map.Last - 1) := Map.Items (J + 1 .. Map.Last); Map.Last := Map.Last - 1; return; end if; end loop; end Remove_Named_Item; ----------------------- -- Remove_Named_Item -- ----------------------- procedure Remove_Named_Item (Map : in out Named_Node_Map; Name : DOM_String; Removed : out Node) is begin for J in 0 .. Map.Last loop if Node_Name (Map.Items (J)) = Name then Removed := Map.Items (J); Map.Items (J .. Map.Last - 1) := Map.Items (J + 1 .. Map.Last); Map.Last := Map.Last - 1; return; end if; end loop; Removed := null; end Remove_Named_Item; ----------------------- -- Remove_Named_Item -- ----------------------- procedure Remove_Named_Item (Map : in out Named_Node_Map; Name : DOM_String) is Remove : Node; begin Remove_Named_Item (Map, Name, Remove); end Remove_Named_Item; ---------- -- Item -- ---------- function Item (Map : Named_Node_Map; Index : Natural) return Node is begin return Item (Node_List (Map), Index); end Item; ------------ -- Length -- ------------ function Length (Map : Named_Node_Map) return Natural is begin return Map.Last + 1; end Length; ----------------------- -- Get_Named_Item_NS -- ----------------------- function Get_Named_Item_NS (Map : Named_Node_Map; Namespace_URI : DOM_String; Local_Name : DOM_String) return Node is begin for J in 0 .. Map.Last loop if Symbol'(DOM.Core.Nodes.Namespace_URI (Map.Items (J))) = Namespace_URI and then Symbol'(DOM.Core.Nodes.Local_Name (Map.Items (J))) = Local_Name then return Map.Items (J); end if; end loop; return null; end Get_Named_Item_NS; -------------------- -- Get_Named_Item -- -------------------- function Get_Named_Item_NS (Map : Named_Node_Map; Namespace_URI : Symbol; Local_Name : Symbol) return Node is begin for J in 0 .. Map.Last loop if DOM.Core.Nodes.Namespace_URI (Map.Items (J)) = Namespace_URI and then DOM.Core.Nodes.Local_Name (Map.Items (J)) = Local_Name then return Map.Items (J); end if; end loop; return null; end Get_Named_Item_NS; ----------------------- -- Set_Named_Item_NS -- ----------------------- procedure Set_Named_Item_NS (Map : in out Named_Node_Map; Arg : Node; Replaces : out Node) is begin Remove_Named_Item_NS (Map, Namespace_URI (Arg), Local_Name (Arg), Replaces); Append (Node_List (Map), Arg); end Set_Named_Item_NS; ----------------------- -- Set_Named_Item_NS -- ----------------------- procedure Set_Named_Item_NS (Map : in out Named_Node_Map; Arg : Node) is Replaces : Node; begin Set_Named_Item_NS (Map, Arg, Replaces); end Set_Named_Item_NS; -------------------------- -- Remove_Named_Item_NS -- -------------------------- procedure Remove_Named_Item_NS (Map : in out Named_Node_Map; Namespace_URI : DOM_String; Local_Name : DOM_String; Removed : out Node) is begin for J in 0 .. Map.Last loop if Symbol'(DOM.Core.Nodes.Namespace_URI (Map.Items (J))) = Namespace_URI and then Symbol'(DOM.Core.Nodes.Local_Name (Map.Items (J))) = Local_Name then Removed := Map.Items (J); Map.Items (J .. Map.Last - 1) := Map.Items (J + 1 .. Map.Last); Map.Last := Map.Last - 1; return; end if; end loop; Removed := null; end Remove_Named_Item_NS; -------------------------- -- Remove_Named_Item_NS -- -------------------------- procedure Remove_Named_Item_NS (Map : in out Named_Node_Map; Namespace_URI : DOM_String; Local_Name : DOM_String) is Removed : Node; begin Remove_Named_Item_NS (Map, Namespace_URI, Local_Name, Removed); end Remove_Named_Item_NS; ---------- -- Free -- ---------- procedure Free (List : in out Node_List; Deep : Boolean) is begin if Deep then for J in 0 .. List.Last loop Free (List.Items (J), Deep => True); end loop; end if; Free (List.Items); end Free; ---------- -- Free -- ---------- procedure Free (N : in out Node; Deep : Boolean := True) is procedure Internal_Free is new Ada.Unchecked_Deallocation (Node_Record, Node); procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Nodes_Htable.HTable, Nodes_Htable_Access); begin if N = null then return; end if; case N.Node_Type is when Element_Node => -- If we have an ID attribute, remove the element from the -- htable. if N.Attributes.Items /= null then for Att in N.Attributes.Items'First .. N.Attributes.Last loop if Attr (N.Attributes.Items (Att)).Is_Id then Document_Remove_Id (Owner_Document (N), N.Attributes.Items (Att).Attr_Value); end if; end loop; end if; Free (Node_List (N.Attributes), Deep => True); Free (N.Children, Deep); when Attribute_Node => null; when Text_Node => Free (N.Text); when Cdata_Section_Node => Free (N.Cdata); when Entity_Reference_Node => null; when Entity_Node => null; when Processing_Instruction_Node => null; when Comment_Node => Free (N.Comment); when Document_Node => Free (N.Doc_Children, Deep); if N.Ids /= null then Nodes_Htable.Reset (N.Ids.all); Unchecked_Free (N.Ids); end if; N.Symbols := No_Symbol_Table; when Document_Type_Node => Free (N.Document_Type_Name); Free (N.Doc_Type_Children, Deep); when Document_Fragment_Node => Free (N.Doc_Frag_Children, Deep); when Notation_Node => Free (N.Public_ID); Free (N.System_ID); end case; Internal_Free (N); end Free; ---------- -- Sort -- ---------- procedure Sort (Map : in out Named_Node_Map) is Arr : Node_Array (0 .. Map.Last + 1) := (others => null); Index : Natural; begin -- ??? The algorithm is not efficient, we use Insertion_Sort for J in 0 .. Map.Last loop Index := 0; loop if Arr (Index) = null then Arr (Index) := Map.Items (J); exit; end if; if Node_Name (Map.Items (J)) <= Node_Name (Arr (Index)) then Arr (Index + 1 .. Arr'Last) := Arr (Index .. Arr'Last - 1); Arr (Index) := Map.Items (J); exit; end if; Index := Index + 1; end loop; end loop; for J in 0 .. Map.Last loop Map.Items (J) := Arr (J); end loop; end Sort; ------------------ -- Print_String -- ------------------ procedure Print_String (Stream : access Ada.Streams.Root_Stream_Type'Class; Str : DOM_String; EOL_Sequence : String; Encoding : Unicode.Encodings.Unicode_Encoding) is J : Natural := Str'First; C : Unicode.Unicode_Char; Buffer : Byte_Sequence (1 .. 20); Index : Natural; begin while J <= Str'Last loop Sax.Encodings.Encoding.Read (Str, J, C); case C is when Ampersand => String'Write (Stream, Amp_DOM_Sequence); when Less_Than_Sign => String'Write (Stream, Lt_DOM_Sequence); when Greater_Than_Sign => String'Write (Stream, Gt_DOM_Sequence); when Quotation_Mark => String'Write (Stream, Quot_DOM_Sequence); -- when Apostrophe => Put ("'"); when Horizontal_Tabulation => String'Write (Stream, Tab_Sequence); when Line_Feed => Put (Stream, EOL_Sequence, Encoding); when Carriage_Return => String'Write (Stream, Cr_Sequence); when 0 .. 8 | 11 .. 12 | 14 .. 31 => declare Img : constant String := Unicode_Char'Image (C); begin String'Write (Stream, "&#" & Img (Img'First + 1 .. Img'Last) & ";"); end; when others => Index := Buffer'First - 1; Encoding.Encoding_Scheme.Encode (Encoding.Character_Set.To_CS (C), Buffer, Index); String'Write (Stream, Buffer (Buffer'First .. Index)); end case; end loop; end Print_String; --------- -- Put -- --------- procedure Put (Stream : access Ada.Streams.Root_Stream_Type'Class; Str : DOM_String; Encoding : Unicode_Encoding) is J : Natural := Str'First; C : Unicode.Unicode_Char; Buffer : Byte_Sequence (1 .. 20); Index : Natural; begin while J <= Str'Last loop Sax.Encodings.Encoding.Read (Str, J, C); Index := Buffer'First - 1; Encoding.Encoding_Scheme.Encode (Encoding.Character_Set.To_CS (C), Buffer, Index); String'Write (Stream, Buffer (Buffer'First .. Index)); end loop; end Put; ---------------- -- Print_Name -- ---------------- procedure Print_Name (Stream : access Ada.Streams.Root_Stream_Type'Class; N : Node; With_URI : Boolean; EOL_Sequence : String; Encoding : Unicode.Encodings.Unicode_Encoding) is begin if With_URI then Print_String (Stream, Namespace_URI (N) & Colon_Sequence & Local_Name (N), EOL_Sequence, Encoding); else Print_String (Stream, Node_Name (N), EOL_Sequence, Encoding); end if; end Print_Name; ----------- -- Write -- ----------- procedure Write (Stream : access Ada.Streams.Root_Stream_Type'Class; N : Node; Print_Comments : Boolean := True; Print_XML_Declaration : Boolean := True; With_URI : Boolean := False; Pretty_Print : Boolean := False; EOL_Sequence : String := "" & ASCII.LF; Encoding : Unicode.Encodings.Unicode_Encoding := Unicode.Encodings.Get_By_Name ("utf-8"); Collapse_Empty_Nodes : Boolean := True) is procedure Recursive_Print (N : Node); -- Print N recursively procedure Recursive_Print (List : Node_List); -- Print all nodes in List function Has_Non_Whitespace (N : Text) return Boolean; -- True if the text code contains text other than whitespaces procedure Newline; -- Go to the next line, when pretty-printing is activated procedure Indent_Line; -- Indent the newline if needed Indent : Natural := 0; At_Bol : Boolean := True; ------------- -- Newline -- ------------- procedure Newline is begin if Pretty_Print then String'Write (Stream, "" & ASCII.LF); At_Bol := True; end if; end Newline; ----------------- -- Indent_Line -- ----------------- procedure Indent_Line is begin if Pretty_Print and At_Bol then String'Write (Stream, (1 .. Indent => ' ')); At_Bol := False; end if; end Indent_Line; ------------------------ -- Has_Non_Whitespace -- ------------------------ function Has_Non_Whitespace (N : Text) return Boolean is Val : constant Byte_Sequence := Node_Value (N); begin for V in Val'Range loop if Val (V) /= ' ' and then Val (V) /= ASCII.HT and then Val (V) /= ASCII.LF then return True; end if; end loop; return False; end Has_Non_Whitespace; --------------------- -- Recursive_Print -- --------------------- procedure Recursive_Print (List : Node_List) is begin for J in 0 .. List.Last loop Recursive_Print (List.Items (J)); end loop; end Recursive_Print; --------------------- -- Recursive_Print -- --------------------- procedure Recursive_Print (N : Node) is begin if N = null then return; end if; case N.Node_Type is when Element_Node => Indent_Line; Put (Stream, Less_Than_Sequence, Encoding); Print_Name (Stream, N, With_URI, EOL_Sequence, Encoding); -- Sort the XML attributes as required for canonical XML Sort (N.Attributes); for J in 0 .. N.Attributes.Last loop Put (Stream, Space_Sequence, Encoding); Recursive_Print (N.Attributes.Items (J)); end loop; if Collapse_Empty_Nodes and then N.Children = Null_List then Put (Stream, Slash_Sequence & Greater_Than_Sequence, Encoding); else Put (Stream, Greater_Than_Sequence, Encoding); -- If the first child is a text node with text other than -- whitespaces, we'll have to preserve whitespaces in the -- children, otherwise we are free to modify them when -- pretty-printing. if Pretty_Print then if Length (N.Children) = 0 or else N.Children.Items (0).Node_Type /= Text_Node or else not Has_Non_Whitespace (N.Children.Items (0)) then Newline; end if; end if; Indent := Indent + 1; Recursive_Print (N.Children); Indent := Indent - 1; Indent_Line; Put (Stream, Less_Than_Sequence & Slash_Sequence, Encoding); Print_Name (Stream, N, With_URI, EOL_Sequence, Encoding); Put (Stream, Greater_Than_Sequence, Encoding); end if; Newline; when Attribute_Node => At_Bol := False; Print_Name (Stream, N, With_URI, EOL_Sequence, Encoding); Put (Stream, Equals_Sign_Sequence & Quotation_Mark_Sequence, Encoding); Print_String (Stream, Node_Value (N), EOL_Sequence, Encoding); Put (Stream, Quotation_Mark_Sequence, Encoding); when Processing_Instruction_Node => Indent_Line; Put (Stream, Less_Than_Sequence & Question_Mark_Sequence & Get (N.Target).all, Encoding); if N.Pi_Data = Empty_String then Put (Stream, Space_Sequence, Encoding); else declare P : constant Cst_Byte_Sequence_Access := Get (N.Pi_Data); C : Unicode_Char; Index : Natural := P'First; begin Sax.Encodings.Encoding.Read (P.all, Index, C); if C /= Space then Put (Stream, Space_Sequence, Encoding); end if; end; end if; Put (Stream, Get (N.Pi_Data).all & Question_Mark_Sequence & Greater_Than_Sequence, Encoding); Newline; when Comment_Node => if Print_Comments then if Pretty_Print then Newline; Indent_Line; end if; Put (Stream, "", Encoding); Newline; end if; when Document_Node => if Print_XML_Declaration then String'Write (Stream, Write_Bom (Encoding.Encoding_Scheme.BOM)); Put (Stream, "", Encoding); Print_String (Stream, "" & ASCII.LF, EOL_Sequence, Encoding); end if; Recursive_Print (N.Doc_Children); when Document_Fragment_Node => Recursive_Print (N.Doc_Frag_Children); when Document_Type_Node | Notation_Node => null; when Text_Node => if not Pretty_Print then Print_String (Stream, Node_Value (N), EOL_Sequence, Encoding); elsif Has_Non_Whitespace (N) then declare Val : constant Byte_Sequence := Node_Value (N); First : Integer := Val'Last + 1; Last : Integer := Val'Last; begin for V in Val'Range loop if Val (V) /= ' ' and then Val (V) /= ASCII.HT and then Val (V) /= ASCII.LF then First := V; exit; end if; end loop; for V in reverse First + 1 .. Val'Last loop if Val (V) /= ' ' and then Val (V) /= ASCII.HT and then Val (V) /= ASCII.LF then Last := V; exit; end if; end loop; Print_String (Stream, Val (First .. Last), EOL_Sequence, Encoding); end; end if; when others => Print_String (Stream, Node_Value (N), EOL_Sequence, Encoding); end case; end Recursive_Print; begin Recursive_Print (N); end Write; ----------- -- Print -- ----------- procedure Print (N : Node; Print_Comments : Boolean := False; Print_XML_PI : Boolean := False; With_URI : Boolean := False; EOL_Sequence : String := Sax.Encodings.Lf_Sequence; Encoding : Unicode.Encodings.Unicode_Encoding := Unicode.Encodings.Get_By_Name ("utf-8"); Collapse_Empty_Nodes : Boolean := False) is begin Write (Stream => Ada.Text_IO.Text_Streams.Stream (Current_Output), N => N, Print_Comments => Print_Comments, Print_XML_Declaration => Print_XML_PI, With_URI => With_URI, EOL_Sequence => EOL_Sequence, Encoding => Encoding, Collapse_Empty_Nodes => Collapse_Empty_Nodes); end Print; ---------- -- Dump -- ---------- procedure Dump (N : Node; With_URI : Boolean := False) is procedure Dump (N : Node; Prefix : String); -- Dump N, with a leading Prefix on the line procedure Dump (List : Node_List; Prefix : String); -- Same as above, but for a list. Encoding : constant Unicode_Encoding := Get_By_Name ("utf-8"); EOL_Sequence : constant Byte_Sequence := Sax.Encodings.Lf_Sequence; Stream : constant Ada.Text_IO.Text_Streams.Stream_Access := Ada.Text_IO.Text_Streams.Stream (Current_Output); ---------- -- Dump -- ---------- procedure Dump (List : Node_List; Prefix : String) is begin for J in 0 .. List.Last loop Dump (List.Items (J), Prefix); end loop; end Dump; ---------- -- Dump -- ---------- procedure Dump (N : Node; Prefix : String) is begin case N.Node_Type is when Element_Node => String'Write (Stream, Prefix & "Element: "); Print_Name (Stream, N, With_URI, EOL_Sequence & ASCII.LF, Encoding); -- Sort the XML attributes as required for canonical XML Sort (N.Attributes); for J in 0 .. N.Attributes.Last loop Dump (N.Attributes.Items (J), Prefix => Prefix & " "); end loop; Dump (N.Children, Prefix & " "); when Attribute_Node => String'Write (Stream, Prefix & "Attribute: "); Print_Name (Stream, N, With_URI, EOL_Sequence, Encoding); Character'Write (Stream, '='); -- ??? Could be a tree Print_String (Stream, Node_Value (N), EOL_Sequence, Encoding); Character'Write (Stream, ASCII.LF); when Processing_Instruction_Node => String'Write (Stream, Prefix & "PI: " & Get (N.Target).all); String'Write (Stream, Prefix & " Data: " & Get (N.Pi_Data).all); when Comment_Node => String'Write (Stream, Prefix & "Comment: " & Node_Value (N)); when Document_Node => String'Write (Stream, Prefix & "Document: "); Dump (N.Doc_Children, Prefix => Prefix & " "); when Document_Fragment_Node => String'Write (Stream, Prefix & "Document_Fragment: "); Dump (N.Doc_Frag_Children, Prefix => Prefix & " "); when Document_Type_Node => String'Write (Stream, Prefix & "Document_Type: "); when Notation_Node => String'Write (Stream, Prefix & "Notation:"); when Text_Node => String'Write (Stream, Prefix & "Text: "); Print_String (Stream, Node_Value (N), EOL_Sequence, Encoding); Character'Write (Stream, ASCII.LF); when Cdata_Section_Node => String'Write (Stream, Prefix & "Cdata: "); Print_String (Stream, Node_Value (N), EOL_Sequence, Encoding); Character'Write (Stream, ASCII.LF); when Entity_Reference_Node => String'Write (Stream, Prefix & "Entity_Reference: "); Print_String (Stream, Node_Value (N), EOL_Sequence, Encoding); Character'Write (Stream, ASCII.LF); when Entity_Node => String'Write (Stream, Prefix & "Entity: "); Print_String (Stream, Node_Value (N), EOL_Sequence, Encoding); Character'Write (Stream, ASCII.LF); end case; end Dump; begin if N /= null then Dump (N, Prefix => ""); end if; end Dump; end DOM.Core.Nodes;