nichkara/lace
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add initial prototype.

Browse Source
This commit is contained in:
Rod Kay
2022-07-31 17:34:54 +10:00
commit 54a53b2ac0
1421 changed files with 358874 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

244
1-base/xml/source/xml-reader.adb Normal file
View File

@@ -0,0 +1,244 @@
with
ada.unchecked_Conversion,
ada.unchecked_Deallocation,
interfaces.C.Strings,
system.Storage_Elements;
package body XML.Reader
is
package C renames Interfaces.C;
package S renames Interfaces.C.Strings;
type XML_Char is new C.unsigned_short;
type XML_Char_Ptr is access all XML_Char;
type Char_Ptr_Ptr is access all S.chars_ptr;
procedure XML_SetUserData (XML_Parser : in XML_Parser_Ptr;
Parser_Ptr : in Parser);
pragma Import (C, XML_SetUserData, "XML_SetUserData");
procedure Internal_Start_Handler (My_Parser : in Parser;
Name : in S.chars_ptr;
AttAdd : in System.Address);
pragma Convention (C, Internal_Start_Handler);
procedure Internal_Start_Handler (My_Parser : in Parser;
Name : in S.chars_ptr;
AttAdd : in System.Address)
is
use S, System, System.Storage_Elements;
procedure Free is new ada.Unchecked_Deallocation (Attributes_t, Attributes_view);
function To_CP is new ada.unchecked_Conversion (System.Address, Char_Ptr_Ptr);
AA_Size : Storage_Offset;
the_Attribute_Array : Attributes_view;
N_Atts : Natural;
Atts : System.Address;
begin
-- Calculate the size of a single attribute (name or value) pointer.
--
AA_Size := S.Chars_Ptr'Size / System.Storage_Unit;
-- Count the number of attributes by scanning for a null pointer.
--
N_Atts := 0;
Atts := AttAdd;
while To_CP (Atts).all /= S.Null_Ptr
loop
N_Atts := N_Atts + 1;
Atts := Atts + (AA_Size * 2);
end loop;
-- Allocate a new attribute array of the correct size.
--
the_Attribute_Array := new Attributes_t (1 .. N_Atts);
-- Convert the attribute strings to unbounded_String.
--
Atts := AttAdd;
for Att in 1 .. N_Atts
loop
the_Attribute_Array (Att).Name := to_unbounded_String (S.Value (To_CP (Atts).all));
Atts := Atts + AA_Size;
the_Attribute_Array (Att).Value := to_unbounded_String (S.Value (To_CP (Atts).all));
Atts := Atts + AA_Size;
end loop;
-- Call the user's handler.
--
My_Parser.Start_Handler (to_unbounded_String (S.Value (Name)),
the_Attribute_Array);
-- Give back the attribute array.
--
Free (the_Attribute_Array);
end Internal_Start_Handler;
procedure Internal_End_Handler (My_Parser : in Parser;
Name : in S.chars_ptr);
pragma Convention (C, Internal_End_Handler);
procedure Internal_End_Handler (My_Parser : in Parser;
Name : in S.chars_ptr)
is
begin
My_Parser.End_Handler (to_unbounded_String (S.Value (Name)));
end Internal_End_Handler;
procedure Internal_CD_Handler (My_Parser : in Parser;
Data : in S.chars_ptr;
Len : in C.int);
pragma Convention (C, Internal_CD_Handler);
procedure Internal_CD_Handler (My_Parser : in Parser;
Data : in S.chars_ptr;
Len : in C.int)
is
the_Data : constant unbounded_String := to_unbounded_String (S.Value (Data, c.size_t (Len)));
begin
if the_Data /= ""
then
My_Parser.CD_Handler (the_Data);
end if;
end Internal_CD_Handler;
function Create_Parser return Parser
is
function XML_ParserCreate (Encoding: in XML_Char_Ptr) return XML_Parser_Ptr;
pragma Import (C, XML_ParserCreate, "XML_ParserCreate");
begin
return new Parser_Rec' (XML_ParserCreate (null),
null,
null,
null);
end Create_Parser;
procedure Set_Element_Handler (The_Parser : in Parser;
Start_Handler : in Start_Element_Handler;
End_Handler : in End_Element_Handler)
is
type Internal_Start_Element_Handler is access procedure (My_Parser : in Parser;
Name : in S.chars_ptr;
AttAdd : in System.Address);
pragma Convention (C, Internal_Start_Element_Handler);
type Internal_End_Element_Handler is access procedure (My_Parser : in Parser;
Name : in S.chars_ptr);
pragma Convention (C, Internal_End_Element_Handler);
procedure XML_SetElementHandler (XML_Parser : in XML_Parser_Ptr;
Start_Handler : in Internal_Start_Element_Handler;
End_Handler : in Internal_End_Element_Handler);
pragma Import (C, XML_SetElementHandler, "XML_SetElementHandler");
begin
XML_SetUserData (The_Parser.XML_Parser,
The_Parser);
The_Parser.Start_Handler := Start_Handler;
The_Parser.End_Handler := End_Handler;
XML_SetElementHandler (The_Parser.XML_Parser, Internal_Start_Handler'Access,
Internal_End_Handler 'Access);
end Set_Element_Handler;
procedure Set_Character_Data_Handler (The_Parser : in Parser;
CD_Handler : in Character_Data_Handler)
is
type Internal_Character_Data_Handler is access procedure (My_Parser : in Parser;
Data : in S.chars_ptr;
Len : in C.int);
pragma Convention (C, Internal_Character_Data_Handler);
procedure XML_SetCharacterDataHandler (XML_Parser : in XML_Parser_Ptr;
CD_Handler : in Internal_Character_Data_Handler);
pragma Import (C, XML_SetCharacterDataHandler, "XML_SetCharacterDataHandler");
begin
XML_SetUserData (The_Parser.XML_Parser, The_Parser);
The_Parser.CD_Handler := CD_Handler;
XML_SetCharacterDataHandler (The_Parser.XML_Parser, Internal_CD_Handler'Access);
end Set_Character_Data_Handler;
procedure Parse (The_Parser : in Parser;
XML : in String;
Is_Final : in Boolean)
is
function XML_Parse (XML_Parser : in XML_Parser_Ptr;
XML : in S.chars_ptr;
Len : in C.int;
Is_Final : in C.int) return C.int;
pragma Import (C, XML_Parse, "XML_Parse");
use C;
XML_STATUS_ERROR : constant C.int := 0;
pragma Unreferenced (XML_STATUS_ERROR);
XML_STATUS_OK : constant C.int := 1;
Final_Flag : C.int;
Status : C.int;
XML_Data : S.chars_ptr;
begin
if Is_Final
then Final_Flag := 1;
else Final_Flag := 0;
end if;
XML_Data := S.New_Char_Array (C.To_C (XML));
Status := XML_Parse (The_Parser.XML_Parser,
XML_Data,
C.int (XML'Length),
Final_Flag);
S.Free (XML_Data);
if Status /= XML_STATUS_OK
then
raise XML_Parse_Error;
end if;
end Parse;
end XML.Reader;

60
1-base/xml/source/xml-reader.ads Normal file
View File

@@ -0,0 +1,60 @@
with
ada.Strings.unbounded;
package XML.Reader
is
use ada.Strings.unbounded;
type Parser is private;
function Create_Parser return Parser;
type Start_Element_Handler is access procedure (Name : in unbounded_String;
Atts : in XML.Attributes_view);
type End_Element_Handler is access procedure (Name : in unbounded_String);
procedure Set_Element_Handler (The_Parser : in Parser;
Start_Handler : in Start_Element_Handler;
End_Handler : in End_Element_Handler);
type Character_Data_Handler is access procedure (Data: in unbounded_String);
procedure Set_Character_Data_Handler (The_Parser : in Parser;
CD_Handler : in Character_Data_Handler);
procedure Parse (The_Parser : in Parser;
XML : in String;
Is_Final : in Boolean);
XML_Parse_Error : exception;
private
type XML_Parser_Ptr is access all Character; -- Essentially, C's "void *".
type Parser_Rec is
record
XML_Parser : XML_Parser_Ptr;
Start_Handler : Start_Element_Handler;
End_Handler : End_Element_Handler;
CD_Handler : Character_Data_Handler;
end record;
type Parser is access Parser_Rec;
-- pragma Linker_Options ("-lexpat");
end XML.Reader;

212
1-base/xml/source/xml-writer.adb Normal file
View File

@@ -0,0 +1,212 @@
with
ada.unchecked_Deallocation;
package body XML.Writer
is
Depth: Natural;
procedure Free is new ada.Unchecked_Deallocation (Attributes_t,
Attributes_view);
procedure Start_Document (F: in ada.Text_IO.File_Type)
is
begin
ada.Text_IO.Put_Line (F, "<?xml version=""1.0"" standalone=""yes""?>");
Depth := 0;
end Start_Document;
procedure End_Document (F: in ada.Text_IO.File_Type)
is
begin
null;
end End_Document;
procedure Start (F: in ada.Text_IO.File_Type;
Name: in String;
Atts: in Attributes_view)
is
begin
for Pad in 1 .. Depth
loop
ada.Text_IO.Put (F, " ");
end loop;
Depth := Depth + 1;
ada.Text_IO.Put (F, "<" & Name);
for Att in Atts'Range
loop
ada.Text_IO.Put (F, " " & to_String (Atts (Att).Name) & "=""" &
to_String (Atts (Att).Value) & """");
end loop;
ada.Text_IO.Put_Line (F, ">");
end Start;
procedure Start (F: in ada.Text_IO.File_Type;
Name: in unbounded_String;
Atts: in Attributes_view)
is
begin
Start (F, to_String (Name), Atts);
end Start;
procedure Finish (F: in ada.Text_IO.File_Type;
Name: in String)
is
begin
Depth := Depth - 1;
for Pad in 1 .. Depth
loop
ada.Text_IO.Put (F, " ");
end loop;
ada.Text_IO.Put_Line (F, "</" & Name & ">");
end Finish;
procedure Finish (F: in ada.Text_IO.File_Type;
Name: in unbounded_String)
is
begin
Finish (F, to_String (Name));
end Finish;
procedure Empty (F: in ada.Text_IO.File_Type;
Name: in String;
Atts: in Attributes_view)
is
begin
for Pad in 1 .. Depth
loop
ada.Text_IO.Put (F, " ");
end loop;
ada.Text_IO.Put (F, "<" & Name);
for Att in Atts'Range
loop
ada.Text_IO.Put (F, " " & to_String (Atts (Att).Name) & "=""" &
to_String (Atts (Att).Value) & """");
end loop;
ada.Text_IO.Put_Line (F, "/>");
end Empty;
procedure Empty (F: in ada.Text_IO.File_Type;
Name: in unbounded_String;
Atts: in Attributes_view)
is
begin
Empty (F, to_String (Name), Atts);
end Empty;
function "+" (K, V: in String) return Attribute_t
is
begin
return Attribute_t'(to_unbounded_String (K),
to_unbounded_String (V));
end "+";
function "+" (K, V: in String) return Attributes_view
is
begin
return new Attributes_t'(1 => Attribute_t'(to_unbounded_String (K),
to_unbounded_String (V)));
end "+";
function "+" (K: in unbounded_String;
V: in String) return Attribute_t
is
begin
return Attribute_t'(K, to_unbounded_String (V));
end "+";
function "+" (K: in unbounded_String;
V: in String) return Attributes_view
is
begin
return new Attributes_t'(1 => Attribute_t' (K, to_unbounded_String (V)));
end "+";
function "+" (K: in String;
V: in unbounded_String) return Attribute_t
is
begin
return Attribute_t'(to_unbounded_String (K), V);
end "+";
function "+" (K: in String;
V: in unbounded_String) return Attributes_view
is
begin
return new Attributes_t'(1 => Attribute_t'(to_unbounded_String (K), V));
end "+";
function MkAtt (L, R: in Attribute_t) return Attributes_view
is
begin
return new Attributes_t'(L, R);
end MkAtt;
function "&" (L, R: in Attribute_t) return Attributes_view
is
begin
return new Attributes_t'(L, R);
end "&";
function "&" (L: in Attributes_view; R: in Attribute_t) return Attributes_view
is
Result: Attributes_view;
ByeBye: Attributes_view;
begin
Result := new Attributes_t (1 .. L'Length + 1);
Result (1 .. L'Length) := L.all;
Result (L'Length + 1) := R;
ByeBye := L;
Free (ByeBye);
return Result;
end "&";
end XML.Writer;

51
1-base/xml/source/xml-writer.ads Normal file
View File

@@ -0,0 +1,51 @@
with
ada.Strings.unbounded,
ada.Text_IO;
package XML.Writer
is
use ada.Strings.unbounded;
procedure Start_Document (F : in ada.Text_IO.File_Type);
procedure End_Document (F : in ada.Text_IO.File_Type);
procedure Start (F : in ada.Text_IO.File_Type;
Name : in String;
Atts : in Attributes_view);
procedure Start (F : in ada.Text_IO.File_Type;
Name : in unbounded_String;
Atts : in Attributes_view);
procedure Finish (F : in ada.Text_IO.File_Type;
Name : in String);
procedure Finish (F : in ada.Text_IO.File_Type;
Name : in unbounded_String);
procedure Empty (F : in ada.Text_IO.File_Type;
Name : in String;
Atts : in Attributes_view);
procedure Empty (F : in ada.Text_IO.File_Type;
Name : in unbounded_String;
Atts : in Attributes_view);
function "+" (K, V : in String) return Attribute_t;
function "+" (K, V : in String) return Attributes_view;
function "+" (K : in unbounded_String;
V : in String) return Attribute_t;
function "+" (K : in unbounded_String;
V : in String) return Attributes_view;
function "+" (K : in String;
V : in unbounded_String) return Attribute_t;
function "+" (K : in String;
V : in unbounded_String) return Attributes_view;
function MkAtt (L, R : in Attribute_t) return Attributes_view;
function "&" (L, R : in Attribute_t) return Attributes_view;
function "&" (L : in Attributes_view; R: in Attribute_t) return Attributes_view;
end XML.Writer;

227
1-base/xml/source/xml.adb Normal file
View File

@@ -0,0 +1,227 @@
with
xml.Reader,
ada.Text_IO;
package body XML
is
------------------
--- Attribute type
--
function Name (Self : in Attribute_t) return String
is
begin
return to_String (Self.Name);
end Name;
function Value (Self : in Attribute_t) return String
is
begin
return to_String (Self.Value);
end Value;
----------------
--- Element type
--
function to_XML (Filename : in String) return Element
is
use xml.Reader, xml.element_Vectors,
ada.Text_IO;
the_Root : aliased Element;
Line_Max : constant := 800_000;
Depth : Natural := 0;
the_XML_File : File_Type;
the_Parser : xml.reader.Parser;
Done : Boolean;
Buffer : String (1 .. Line_Max);
Buffer_Length : Natural;
element_Stack : element_Vector;
function current_Element return Element_view
is
begin
return element_Stack.last_Element;
end current_Element;
procedure Starter (Name: in unbounded_String;
Atts: in Attributes_view)
is
new_Element : constant Element_view := new Element' (name => Name,
attributes => new Attributes_t' (Atts.all),
data => <>,
parent => current_Element,
children => <>);
begin
current_Element.add_Child (new_Element);
element_Stack .append (new_Element);
end Starter;
procedure Ender (Name: in unbounded_String)
is
pragma Unreferenced (Name);
begin
element_Stack.delete_Last;
end Ender;
procedure data_Handler (Data: in unbounded_String)
is
begin
append (current_Element.Data, "" & Data);
end data_Handler;
begin
append (element_Stack, the_Root'unchecked_Access);
open (the_XML_File, In_File, Filename);
the_Parser := Create_Parser;
set_Element_Handler (the_Parser, Starter 'unrestricted_Access,
Ender 'unrestricted_Access);
set_Character_Data_Handler (the_Parser, data_Handler'unrestricted_Access);
loop
Get_Line (the_XML_File, Buffer, Buffer_Length);
Done := End_Of_File (the_XML_File);
Parse (the_Parser, Buffer (1 .. Buffer_Length), Done);
exit when Done;
end loop;
close (the_XML_File);
return the_Root;
end to_XML;
function Name (Self : in Element) return String
is
begin
return to_String (Self.Name);
end Name;
function Data (Self : in Element) return String
is
begin
return to_String (Self.Data);
end Data;
function Children (Self : in Element) return Elements
is
the_Children : Elements (1 .. Integer (Self.children.Length));
begin
for Each in the_Children'Range
loop
the_Children (Each) := Self.Children.Element (Each);
end loop;
return the_Children;
end Children;
function Children (Self : in Element; Named : in String) return Elements
is
the_Children : Elements (1 .. Integer (Self.children.Length));
Count : Natural := 0;
begin
for Each in the_Children'Range
loop
if Self.Children.Element (Each).Name = Named
then
Count := Count + 1;
the_Children (Count) := Self.Children.Element (Each);
end if;
end loop;
return the_Children (1 .. Count);
end Children;
procedure add_Child (Self : in out Element; the_Child : access Element)
is
begin
Self.Children.append (the_Child.all'Access);
end add_Child;
function Child (Self : in Element; Named : in String) return access Element
is
use element_Vectors;
Cursor : element_Vectors.Cursor := Self.children.First;
begin
while has_Element (Cursor)
loop
if element_Vectors.Element (Cursor).Name = Named
then
return element_Vectors.Element (Cursor);
end if;
next (Cursor);
end loop;
return null;
end Child;
function Attributes (Self : in Element) return Attributes_t
is
begin
return Self.Attributes.all;
end Attributes;
function Attribute (Self : in Element; Named : in String) return access Attribute_t'Class
is
begin
for Each in Self.Attributes'Range
loop
if Self.Attributes (Each).Name = Named
then
return Self.Attributes (Each)'Access;
end if;
end loop;
return null;
end Attribute;
function Parent (Self : in Element) return access Element
is
begin
return Self.Parent;
end Parent;
end XML;

107
1-base/xml/source/xml.ads Normal file
View File

@@ -0,0 +1,107 @@
private
with
ada.Strings.unbounded,
ada.Containers.vectors;
package XML
--
-- Provides simple XML reader/writer support.
--
-- Heavily based on Chip Richards Ada XML packages.
--
is
--- Attribute type
--
type Attribute_t is tagged private;
type Attributes_t is array (Positive range <>) of aliased Attribute_t;
type Attributes_view is access all Attributes_t;
function Name (Self : in Attribute_t) return String;
function Value (Self : in Attribute_t) return String;
--- Element type
--
type Element is tagged private;
type Elements is array (Positive range <>) of access Element;
-- Construction
--
function to_XML (Filename : in String) return Element;
--
-- Parses 'Filename' and returns the root node Element of the parsed XML tree.
-- Attributes
--
function Name (Self : in Element) return String;
function Attributes (Self : in Element) return Attributes_t;
function Data (Self : in Element) return String;
function Attribute (Self : in Element; Named : in String) return access Attribute_t'Class;
--
-- Returns null if the named attribute does not exist.
-- Hierachy
--
function Parent (Self : in Element) return access Element;
function Children (Self : in Element) return Elements;
function Child (Self : in Element; Named : in String) return access Element;
--
-- Returns null if the named child does not exist.
function Children (Self : in Element; Named : in String) return Elements;
procedure add_Child (Self : in out Element; the_Child : access Element);
private
use ada.Strings.unbounded;
type Attribute_t is tagged
record
Name : unbounded_String;
Value : unbounded_String;
end record;
type Element_view is access all Element;
package element_Vectors is new ada.containers.Vectors (Positive, Element_view);
subtype element_Vector is element_vectors.Vector;
type Element is tagged
record
Name : unbounded_String;
Attributes : Attributes_view;
Data : unbounded_String;
Parent : Element_view;
Children : element_Vector;
end record;
end XML;