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

16
1-base/xml/alire.toml Normal file
View File

@@ -0,0 +1,16 @@
name = "lace_xml"
description = "Provides simple XML read/write support."
version = "0.1.1"
authors = ["Rod Kay"]
maintainers = ["Rod Kay <rodakay5@gmail.com>"]
maintainers-logins = ["charlie5"]
licenses = "ISC"
website = "https://github.com/charlie5/lace-alire"
project-files = ["library/xml.gpr"]
[[depends-on]]
lace_shared = "~0.1"
libexpat = "*"

103
1-base/xml/applet/demo/outline/deer.dae Normal file
View File

File diff suppressed because one or more lines are too long

89
1-base/xml/applet/demo/outline/launch_outline.adb Normal file
View File

@@ -0,0 +1,89 @@
with
ada.command_Line,
ada.Text_IO,
ada.Strings.unbounded,
xml.Reader;
procedure launch_Outline
is
use ada.command_Line,
ada.Text_IO,
ada.Strings.unbounded,
XML.Reader;
Line_Max : constant := 60000;
Depth : natural := 0;
XML_File : File_Type;
MyParser : Parser;
Done : Boolean;
Buffer : String (1 .. Line_Max);
Buffer_Length : Natural;
procedure Starter (Name : in Unbounded_String;
Atts : in XML.Attributes_view)
is
begin
for Pad in 1 .. Depth
loop
put (" ");
end loop;
Put (To_String (Name));
for Att in Atts'Range
loop
put (" " & Atts (Att).Name & " = " & Atts (Att).Value);
end loop;
new_Line;
Depth := Depth + 1;
end Starter;
procedure Ender (Name : in unbounded_String)
is
pragma Unreferenced (Name);
begin
Depth := Depth - 1;
end Ender;
procedure my_data_Handler (Data : in unbounded_String)
is
begin
put_Line ("my_data_Handler: '" & to_String (Data) & "'");
end my_data_Handler;
begin
if Argument_Count < 1
then
Put_Line (Standard_Error, "usage: outline xml-file");
else
open (XML_File, In_File, Argument (1));
MyParser := Create_Parser;
set_Element_Handler (MyParser, Starter'unrestricted_Access,
Ender 'unrestricted_Access);
set_Character_Data_Handler (myParser, my_data_Handler'unrestricted_Access);
loop
get_Line (XML_File, Buffer, Buffer_Length);
Done := End_Of_File (XML_File);
parse (MyParser,
Buffer (1 .. Buffer_Length),
Done);
exit when Done;
end loop;
end if;
end launch_Outline;

16
1-base/xml/applet/demo/outline/outline.gpr Normal file
View File

@@ -0,0 +1,16 @@
with
"xml",
"lace_shared";
project Outline
is
for Object_Dir use "build";
for Exec_Dir use ".";
for Main use ("launch_outline.adb");
package Ide renames Lace_shared.Ide;
package Builder renames Lace_shared.Builder;
package Compiler renames Lace_shared.Compiler;
package Binder renames Lace_shared.Binder;
end Outline;

148
1-base/xml/applet/demo/tree/box.dae Normal file
View File

@@ -0,0 +1,148 @@
<?xml version="1.0" encoding="utf-8"?>
<COLLADA xmlns="http://www.collada.org/2005/11/COLLADASchema" version="1.4.1">
<asset>
<contributor>
<author>Blender User</author>
<authoring_tool>Blender 2.55.0 r-UNKNOWN-</authoring_tool>
</contributor>
<created>2010-11-28T13:09:56</created>
<modified>2010-11-28T13:09:56</modified>
<unit name="meter" meter="1"/>
<up_axis>Z_UP</up_axis>
</asset>
<library_cameras>
<camera id="Camera-camera" name="Camera">
<optics>
<technique_common>
<perspective>
<xfov>49.13434</xfov>
<aspect_ratio>1.777778</aspect_ratio>
<znear>0.099999964237</znear>
<zfar>100</zfar>
</perspective>
</technique_common>
</optics>
</camera>
</library_cameras>
<library_lights>
<light id="Lamp-light" name="Lamp">
<technique_common>
<point>
<color>1 1 1</color>
<constant_attenuation>1</constant_attenuation>
<linear_attenuation>0</linear_attenuation>
<quadratic_attenuation>5.55556e-4</quadratic_attenuation>
</point>
</technique_common>
</light>
</library_lights>
<library_images/>
<library_effects>
<effect id="Material-effect">
<profile_COMMON>
<technique sid="common">
<lambert>
<emission>
<color>0 0 0 1</color>
</emission>
<ambient>
<color>0 0 0 1</color>
</ambient>
<diffuse>
<color>0.6400000453 0.6400000453 0.6400000453 1</color>
</diffuse>
<index_of_refraction>
<float>1</float>
</index_of_refraction>
</lambert>
<extra/>
</technique>
<extra>
<technique profile="GOOGLEEARTH">
<show_double_sided>1</show_double_sided>
</technique>
</extra>
</profile_COMMON>
<extra><technique profile="MAX3D"><double_sided>1</double_sided></technique></extra>
</effect>
</library_effects>
<library_materials>
<material id="Material" name="Material">
<instance_effect url="#Material-effect"/>
</material>
</library_materials>
<library_geometries>
<geometry id="Cube-mesh">
<mesh>
<source id="Cube-mesh-positions">
<float_array id="Cube-mesh-positions-array" count="24">1 0.999999940395 -1 1 -1 -1 -1 -0.999999821186 -1 -0.999999642372 1 -1 1 0.999999463558 1 0.999999344348 -1.000001 1 -1 -0.999999642372 1 -0.999999940395 1 1</float_array>
<technique_common>
<accessor source="#Cube-mesh-positions-array" count="8" stride="3">
<param name="X" type="float"/>
<param name="Y" type="float"/>
<param name="Z" type="float"/>
</accessor>
</technique_common>
</source>
<source id="Cube-mesh-normals">
<float_array id="Cube-mesh-normals-array" count="18">0 0 -1 0 0 1 1 -2.83122e-7 0 -2.83122e-7 -1 0 -1 2.23517e-7 -1.3411e-7 2.38419e-7 1 2.08616e-7</float_array>
<technique_common>
<accessor source="#Cube-mesh-normals-array" count="6" stride="3">
<param name="X" type="float"/>
<param name="Y" type="float"/>
<param name="Z" type="float"/>
</accessor>
</technique_common>
</source>
<vertices id="Cube-mesh-vertices">
<input semantic="POSITION" source="#Cube-mesh-positions"/>
</vertices>
<polylist material="Material" count="6">
<input semantic="VERTEX" source="#Cube-mesh-vertices" offset="0"/>
<input semantic="NORMAL" source="#Cube-mesh-normals" offset="1"/>
<vcount>4 4 4 4 4 4 </vcount>
<p>0 0 1 0 2 0 3 0 4 1 7 1 6 1 5 1 0 2 4 2 5 2 1 2 1 3 5 3 6 3 2 3 2 4 6 4 7 4 3 4 4 5 0 5 3 5 7 5</p>
</polylist>
</mesh>
</geometry>
</library_geometries>
<library_animations/>
<library_controllers/>
<library_visual_scenes>
<visual_scene id="Scene" name="Scene">
<node id="Cube" type="NODE">
<translate sid="location">0 0 0</translate>
<rotate sid="rotationZ">0 0 1 0</rotate>
<rotate sid="rotationY">0 1 0 0</rotate>
<rotate sid="rotationX">1 0 0 0</rotate>
<scale sid="scale">1 1 1</scale>
<instance_geometry url="#Cube-mesh">
<bind_material>
<technique_common>
<instance_material symbol="Material" target="#Material"/>
</technique_common>
</bind_material>
</instance_geometry>
</node>
<node id="Lamp" type="NODE">
<translate sid="location">4.076245 1.005454 5.903862</translate>
<rotate sid="rotationZ">0 0 1 106.9363</rotate>
<rotate sid="rotationY">0 1 0 3.163707</rotate>
<rotate sid="rotationX">1 0 0 37.26105</rotate>
<scale sid="scale">1 1 1</scale>
<instance_light url="#Lamp-light"/>
</node>
<node id="Camera" type="NODE">
<translate sid="location">7.481132 -6.50764 5.343665</translate>
<rotate sid="rotationZ">0 0 1 46.69194</rotate>
<rotate sid="rotationY">0 1 0 0.619767916163</rotate>
<rotate sid="rotationX">1 0 0 63.55929</rotate>
<scale sid="scale">1 1 1</scale>
<instance_camera url="#Camera-camera"/>
</node>
</visual_scene>
</library_visual_scenes>
<scene>
<instance_visual_scene url="#Scene"/>
</scene>
</COLLADA>

42
1-base/xml/applet/demo/tree/launch_tree.adb Normal file
View File

@@ -0,0 +1,42 @@
with
XML,
ada.Text_IO;
procedure launch_Tree
--
-- Loads an xml file, parses it into a tree and displays the tree.
--
is
the_Tree : constant xml.Element := xml.to_XML ("./box.dae");
Depth : Natural := 0;
procedure show_Element (the_Element : in xml.Element)
is
use ada.Text_IO;
the_Children : constant xml.Elements := the_Element.Children;
begin
Depth := Depth + 1;
for Each in 1 .. Depth-1
loop
put (" ");
end loop;
put_Line (the_Element.Name);
for Each in the_Children'range
loop
show_Element (the_Children (Each).all);
end loop;
Depth := Depth - 1;
end show_Element;
begin
show_Element (the_Tree);
end launch_Tree;

15
1-base/xml/applet/demo/tree/xml_tree.gpr Normal file
View File

@@ -0,0 +1,15 @@
with
"xml",
"lace_shared";
project Xml_Tree
is
for Object_Dir use "build";
for Exec_Dir use ".";
for Main use ("launch_tree.adb");
package Ide renames Lace_shared.Ide;
package Builder renames Lace_shared.Builder;
package Compiler renames Lace_shared.Compiler;
package Binder renames Lace_shared.Binder;
end Xml_Tree;

18
1-base/xml/applet/demo/write/launch_write.adb Normal file
View File

@@ -0,0 +1,18 @@
with
ada.Text_IO,
xml.Writer;
procedure launch_Write
is
use ada.Text_IO, xml.Writer;
begin
start_Document (Standard_Output);
start (standard_Output, "foo", "bar" + "bing");
empty (standard_Output, "frodo", MkAtt ("hobbit" + "true", "ring" + "1") & ("purpose" + "To rule them all."));
finish (standard_Output, "foo");
end_Document (Standard_Output);
end launch_Write;

16
1-base/xml/applet/demo/write/write.gpr Normal file
View File

@@ -0,0 +1,16 @@
with
"xml",
"lace_shared";
project Write
is
for Object_Dir use "build";
for Exec_Dir use ".";
for Main use ("launch_write.adb");
package Ide renames Lace_shared.Ide;
package Builder renames Lace_shared.Builder;
package Compiler renames Lace_shared.Compiler;
package Binder renames Lace_shared.Binder;
end Write;

24
1-base/xml/library/xml.gpr Normal file
View File

@@ -0,0 +1,24 @@
with
"lace_shared";
--library
project Xml
is
for Create_Missing_Dirs use "True";
for Source_Dirs use ("../source");
for Object_Dir use "build";
for Library_Dir use "lib";
for Library_Ali_Dir use "objects";
-- for Library_Name use "Xml";
package Ide renames Lace_shared.Ide;
package Builder renames Lace_shared.Builder;
package Compiler renames Lace_shared.Compiler;
package Binder renames Lace_shared.Binder;
package Linker is
for Linker_Options use ("-g", "-lexpat");
end Linker;
end Xml;

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;