------------------------------------------------------------------------------ -- XML/Ada - An XML suite for Ada95 -- -- -- -- Copyright (C) 2001-2012, 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. -- -- -- -- -- -- -- -- -- -- -- -- 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. function Clone_List (List : node_list; Deep : Boolean) return node_list; -- Return a clone of List. If Deep is True, then each item in the list -- is also cloned 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 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 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)); -- ??? New_Child should use Shared strings from the new document -- ??? Should check that New_Child was created from the same document -- (ie same DTD,...), or raise Wrong_Document_Err -- 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 -- ??? New_Child should use Shared strings from the new document 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 begin -- ??? Shared strings should be duplicated, so as not to depend on the -- initial document case N.Node_Type is when element_node => Remove (N.Children, Old_Child); when document_node => Remove (N.Doc_Children, Old_Child); when document_type_node => return null; when document_fragment_node => Remove (N.Doc_Frag_Children, Old_Child); when others => return null; end case; return Old_Child; 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_List -- ---------------- function Clone_List (List : node_list; Deep : Boolean) 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.all), Last => List.Last); for J in 0 .. L.Last loop L.Items (J) := List.Items (J); end loop; end if; return L; end Clone_List; ---------------- -- Clone_Node -- ---------------- function Clone_Node (N : node; Deep : Boolean) return node is Clone : node; 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)); when attribute_node => Clone.Attr_Name := N.Attr_Name; Clone.Attr_Value := N.Attr_Value; 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;