mirror of
https://github.com/AdaCore/xmlada.git
synced 2026-02-12 12:30:28 -08:00
1377514177
... to allow to reuse node inside the same document and to avoid dangling pointers. Raise exception when node is not found as required by DOM specification. Change-Id: I46eabf3938afba56a1f5061db6f1b2ded186a6e6
268 lines
8.1 KiB
Ada
268 lines
8.1 KiB
Ada
------------------------------------------------------------------------------
|
|
-- XML/Ada - An XML suite for Ada95 --
|
|
-- --
|
|
-- Copyright (C) 2001-2021, 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 --
|
|
-- <http://www.gnu.org/licenses/>. --
|
|
-- --
|
|
------------------------------------------------------------------------------
|
|
|
|
with Unicode.CES; use Unicode.CES;
|
|
with Sax.Encodings; use Sax.Encodings;
|
|
with Unicode.Names.Basic_Latin; use Unicode.Names.Basic_Latin;
|
|
with Unicode; use Unicode;
|
|
with Sax.Symbols; use Sax.Symbols;
|
|
with Sax.Utils; use Sax.Utils;
|
|
|
|
package body DOM.Core is
|
|
use Nodes_Htable, Symbol_Table_Pointers;
|
|
|
|
Node_List_Growth_Factor : Float := Default_Node_List_Growth_Factor;
|
|
|
|
---------------------------------
|
|
-- Set_Node_List_Growth_Factor --
|
|
---------------------------------
|
|
|
|
procedure Set_Node_List_Growth_Factor (Factor : Float) is
|
|
begin
|
|
Node_List_Growth_Factor := Factor;
|
|
end Set_Node_List_Growth_Factor;
|
|
|
|
---------------------
|
|
-- Create_Document --
|
|
---------------------
|
|
|
|
function Create_Document
|
|
(Implementation : DOM_Implementation;
|
|
NameSpace_URI : DOM_String := "";
|
|
Qualified_Name : DOM_String := "";
|
|
Doc_Type : Node := null;
|
|
Symbols : Sax.Utils.Symbol_Table := Sax.Utils.No_Symbol_Table)
|
|
return Node
|
|
is
|
|
pragma Warnings (Off, NameSpace_URI);
|
|
pragma Warnings (Off, Qualified_Name);
|
|
Sym : Sax.Utils.Symbol_Table := Symbols;
|
|
Tmp : Symbol_Table_Access;
|
|
begin
|
|
pragma Assert
|
|
(Doc_Type = null or else Doc_Type.Node_Type = Document_Type_Node);
|
|
if Sym = No_Symbol_Table then
|
|
Tmp := new Symbol_Table_Record;
|
|
Sym := Symbol_Table_Pointers.Allocate (Tmp);
|
|
end if;
|
|
return new Node_Record'
|
|
(Node_Type => Document_Node,
|
|
Parent => null,
|
|
Doc_Children => Null_List,
|
|
Doc_Type => Doc_Type,
|
|
Parent_Is_Owner => False,
|
|
Implementation => Implementation,
|
|
Ids => null,
|
|
Symbols => Sym);
|
|
end Create_Document;
|
|
|
|
-----------------
|
|
-- Has_Feature --
|
|
-----------------
|
|
|
|
function Has_Feature
|
|
(Implementation : DOM_Implementation;
|
|
Feature : DOM_String;
|
|
Version : String := "2.0") return Boolean
|
|
is
|
|
pragma Warnings (Off, Implementation);
|
|
begin
|
|
return Feature = "XML" and then Version = "2.0";
|
|
end Has_Feature;
|
|
|
|
------------
|
|
-- Append --
|
|
------------
|
|
|
|
procedure Append (List : in out Node_List; N : Node) is
|
|
Old : Node_Array_Access := List.Items;
|
|
begin
|
|
if Old = null or else Old'Last = List.Last then
|
|
List.Items := new Node_Array
|
|
(0 .. List.Last + 1
|
|
+ (Integer'Max (0,
|
|
Integer (Float (List.Last) * Node_List_Growth_Factor))));
|
|
if Old /= null then
|
|
List.Items (0 .. List.Last) := Old.all;
|
|
Free (Old);
|
|
end if;
|
|
end if;
|
|
List.Last := List.Last + 1;
|
|
List.Items (List.Last) := N;
|
|
end Append;
|
|
|
|
------------
|
|
-- Remove --
|
|
------------
|
|
|
|
procedure Remove
|
|
(List : in out Node_List;
|
|
N : Node;
|
|
Success : out Boolean) is
|
|
begin
|
|
if List.Items /= null then
|
|
for J in 0 .. List.Last loop
|
|
if List.Items (J) = N then
|
|
List.Items (J .. List.Last - 1) :=
|
|
List.Items (J + 1 .. List.Last);
|
|
List.Last := List.Last - 1;
|
|
Success := True;
|
|
|
|
return;
|
|
end if;
|
|
end loop;
|
|
end if;
|
|
|
|
Success := False;
|
|
end Remove;
|
|
|
|
----------
|
|
-- Free --
|
|
----------
|
|
|
|
procedure Free (List : in out Node_List) is
|
|
begin
|
|
Free (List.Items);
|
|
end Free;
|
|
|
|
--------------------
|
|
-- Qualified_Name --
|
|
--------------------
|
|
|
|
function Qualified_Name (N : Node_Name_Def) return DOM_String is
|
|
begin
|
|
pragma Assert (N.Local_Name /= No_Symbol);
|
|
if N.Prefix = No_Symbol or N.Prefix = Empty_String then
|
|
return Get (N.Local_Name).all;
|
|
else
|
|
return Get (N.Prefix).all & Colon_Sequence & Get (N.Local_Name).all;
|
|
end if;
|
|
end Qualified_Name;
|
|
|
|
----------------
|
|
-- Set_Prefix --
|
|
----------------
|
|
|
|
procedure Set_Prefix (N : in out Node_Name_Def; Prefix : Symbol) is
|
|
begin
|
|
-- ??? We're supposed to check that Prefix is valid, and raise
|
|
-- Invalid_Character_Err otherwise
|
|
|
|
N.Prefix := Prefix;
|
|
end Set_Prefix;
|
|
|
|
-------------------------
|
|
-- From_Qualified_Name --
|
|
-------------------------
|
|
|
|
function From_Qualified_Name
|
|
(Doc : Document;
|
|
Symbols : Sax.Utils.Symbol_Table;
|
|
Name : Sax.Symbols.Symbol;
|
|
Namespace : Sax.Symbols.Symbol := Sax.Symbols.No_Symbol)
|
|
return Node_Name_Def
|
|
is
|
|
N : constant Cst_Byte_Sequence_Access := Get (Name);
|
|
Index : Natural := N'First;
|
|
Colon_Pos : Natural;
|
|
C : Unicode_Char := 0;
|
|
begin
|
|
-- ??? Test for Invalid_Character_Err
|
|
-- ??? Must convert Tag_Name to uppercase for HTML documents
|
|
-- ??? Test for Namespace_Err
|
|
|
|
while Index <= N'Last loop
|
|
Colon_Pos := Index;
|
|
Encoding.Read (N.all, Index, C);
|
|
exit when C = Colon;
|
|
end loop;
|
|
|
|
if C = Colon then
|
|
return
|
|
(Prefix => Find (Doc.Symbols, N (N'First .. Colon_Pos - 1)),
|
|
Local_Name => Find (Doc.Symbols, N (Index .. N'Last)),
|
|
Namespace => Namespace);
|
|
|
|
elsif Symbols /= Doc.Symbols then
|
|
return
|
|
(Prefix => Find (Doc.Symbols, Get (Name).all),
|
|
Local_Name => Find (Doc.Symbols, Get (Namespace).all),
|
|
Namespace => Namespace);
|
|
else
|
|
return
|
|
(Prefix => No_Symbol,
|
|
Local_Name => Name,
|
|
Namespace => Namespace);
|
|
end if;
|
|
end From_Qualified_Name;
|
|
|
|
----------
|
|
-- Free --
|
|
----------
|
|
|
|
procedure Free (N : in out Node_String) is
|
|
pragma Unreferenced (N);
|
|
begin
|
|
null;
|
|
end Free;
|
|
|
|
-------------
|
|
-- Get_Key --
|
|
-------------
|
|
|
|
function Get_Key (N : Node_String) return Symbol is
|
|
begin
|
|
return N.Key;
|
|
end Get_Key;
|
|
|
|
---------------------
|
|
-- Document_Add_Id --
|
|
---------------------
|
|
|
|
procedure Document_Add_Id
|
|
(Doc : Document;
|
|
Id : Symbol;
|
|
Elem : Element) is
|
|
begin
|
|
if Doc.Ids = null then
|
|
Doc.Ids := new Nodes_Htable.HTable (203);
|
|
end if;
|
|
|
|
Set (Doc.Ids.all, (N => Node (Elem), Key => Id));
|
|
end Document_Add_Id;
|
|
|
|
------------------------
|
|
-- Document_Remove_Id --
|
|
------------------------
|
|
|
|
procedure Document_Remove_Id
|
|
(Doc : Document;
|
|
Id : Symbol) is
|
|
begin
|
|
if Doc.Ids /= null then
|
|
Remove (Doc.Ids.all, Id);
|
|
end if;
|
|
end Document_Remove_Id;
|
|
|
|
end DOM.Core;
|