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

14
1-base/lace/applet/demo/event/distributed/builder.sh Executable file
View File

@@ -0,0 +1,14 @@
#!/bin/bash
set -e
export OS=Linux
mkdir -p build
rm -fr dsa
export Build_Mode=debug
po_gnatdist -P simple_chat.gpr simple_chat.dsa -cargs -g -largs -g
#rm -fr build
#rm -fr dsa

47
1-base/lace/applet/demo/event/distributed/launch_simple_chat_client.adb Normal file
View File

@@ -0,0 +1,47 @@
with
chat.Client.local,
lace.Event.utility,
ada.Characters.latin_1,
ada.command_Line,
ada.Text_IO,
ada.Exceptions;
procedure launch_simple_chat_Client
--
-- Starts a chat client.
--
is
use ada.Text_IO;
begin
-- Usage
--
if ada.command_Line.argument_Count /= 1
then
put_Line ("Usage: $ ./launch_simple_chat_Client <nickname>");
return;
end if;
declare
use chat.Client.local;
client_Name : constant String := ada.command_Line.Argument (1);
the_Client : chat.Client.local.item := to_Client (client_Name);
begin
the_Client.start;
end;
exception
when E : others =>
lace.Event.utility.close;
new_Line;
put_Line ("~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~");
put_Line ("Unhandled exception, aborting. Please report the following to developer.");
put_Line ("________________________________________________________________________");
put_Line (ada.Exceptions.exception_Information (E));
put (ada.Characters.latin_1.ESC & "[1A"); -- Move cursor up.
put_Line ("________________________________________________________________________");
new_Line;
end launch_simple_chat_Client;

35
1-base/lace/applet/demo/event/distributed/launch_simple_chat_registrar.adb Normal file
View File

@@ -0,0 +1,35 @@
with
chat.Registrar,
ada.Exceptions,
ada.Characters.latin_1,
ada.Text_IO;
procedure launch_simple_chat_Registrar
--
-- Launches the chat registrar.
--
is
use ada.Text_IO;
begin
loop
declare
Command : constant String := get_Line;
begin
exit when Command = "q";
end;
end loop;
put_Line ("Shutting down.");
chat.Registrar.shutdown;
exception
when E : others =>
new_Line;
put_Line ("~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~");
put_Line ("Unhandled exception, aborting. Please report the following to developer.");
put_Line ("________________________________________________________________________");
put_Line (ada.Exceptions.exception_Information (E));
put (ada.Characters.latin_1.ESC & "[1A"); -- Move cursor up.
put_Line ("________________________________________________________________________");
new_Line;
end launch_simple_chat_Registrar;

70
1-base/lace/applet/demo/event/distributed/simple_chat.dsa Normal file
View File

@@ -0,0 +1,70 @@
configuration simple_Chat is
pragma Starter (none);
--
-- Tell 'po_gnatdist' to not create any startup script or launcher.
-- We will launch our Server and Client partitions manually from a console.
-- Server
--
registrar_Partition : partition := (chat.Registrar);
--
-- Declare the Registrar partition and assign the Registrars 'remote call interface' package to this partition.
for registrar_Partition'Termination use Local_Termination;
procedure launch_simple_chat_Registrar is in registrar_Partition;
--
-- Tell po_gnatdist that the 'launch_simple_chat_Registrar' procedure is the the Servers 'main' subprogram or launcher.
-- Client
--
client_Partition : partition;
--
-- Declare the Client partition (which has no remote call interface package associated with it, so no 'initialisation' is required).
procedure launch_simple_chat_Client;
--
-- Declare the Clients 'main' subprogram or launcher.
for client_Partition'Main use launch_simple_chat_Client;
--
-- Tell po_gnatdist to assign the above declared 'launch_simple_chat_Client' procedure as the Clients 'main' subprogram or launcher.
for client_Partition'Termination use Local_Termination;
--
-- Tell po_Gnatdist that Clients may terminate locally (more on this later).
-- Channels
--
-- The zip filter works only on 32 bits machines, don't try it on Digital Unix/Alpha.
--
-- Channel_1 : Channel := (server_Partition, client_Partition);
-- for Channel_1'Filter use "zip";
-- Misc
--
for Partition'Directory use "bin";
--
-- Ask po_gnatdist to place the built Client and Server partition executables in the './bin' sub-folder.
end simple_Chat;

28
1-base/lace/applet/demo/event/distributed/simple_chat.gpr Normal file
View File

@@ -0,0 +1,28 @@
with
"lace",
"lace_shared";
project simple_Chat
is
for Create_Missing_Dirs use "True";
for Object_Dir use "build";
for Exec_Dir use ".";
-- for Main use ("launch_simple_chat_client.adb",
-- "launch_simple_chat_registrar.adb");
for Source_Dirs use (".",
"source");
package Dsa is
for Configuration_File use "simple_chat.dsa";
end Dsa;
package Builder renames Lace_shared.Builder;
package Compiler renames Lace_shared.Compiler;
package Binder renames Lace_shared.Binder;
package Linker is
for Default_Switches ("ada") use ("-g");
end Linker;
end simple_Chat;

297
1-base/lace/applet/demo/event/distributed/source/chat-client-local.adb Normal file
View File

@@ -0,0 +1,297 @@
with
chat.Registrar,
lace.Response,
lace.Observer,
lace.Event.utility,
system.RPC,
ada.Exceptions,
ada.Text_IO;
package body chat.Client.local
is
-- Utility
--
function "+" (From : in unbounded_String) return String
renames to_String;
-- Responses
--
type Show is new lace.Response.item with null record;
-- Response is to display the chat message on the users console.
--
overriding
procedure respond (Self : in out Show; to_Event : in lace.Event.item'Class)
is
pragma Unreferenced (Self);
use ada.Text_IO;
the_Message : constant Message := Message (to_Event);
begin
put_Line (the_Message.Text (1 .. the_Message.Length));
end respond;
the_Response : aliased chat.Client.local.show;
-- Forge
--
function to_Client (Name : in String) return Item
is
begin
return Self : Item
do
Self.Name := to_unbounded_String (Name);
end return;
end to_Client;
-- Attributes
--
overriding
function Name (Self : in Item) return String
is
begin
return to_String (Self.Name);
end Name;
overriding
function as_Observer (Self : access Item) return lace.Observer.view
is
begin
return Self;
end as_Observer;
overriding
function as_Subject (Self : access Item) return lace.Subject.view
is
begin
return Self;
end as_Subject;
-- Operations
--
overriding
procedure register_Client (Self : in out Item; other_Client : in Client.view)
is
use lace.Event.utility,
ada.Text_IO;
begin
lace.Event.utility.connect (the_Observer => Self'unchecked_Access,
to_Subject => other_Client.as_Subject,
with_Response => the_Response'Access,
to_Event_Kind => to_Kind (chat.Client.Message'Tag));
put_Line (other_Client.Name & " is here.");
end register_Client;
overriding
procedure deregister_Client (Self : in out Item; other_Client_as_Observer : in lace.Observer.view;
other_Client_Name : in String)
is
use lace.Event.utility,
ada.Text_IO;
begin
begin
Self.as_Subject.deregister (other_Client_as_Observer,
to_Kind (chat.Client.Message'Tag));
exception
when constraint_Error =>
raise unknown_Client with "Other client not known. Deregister is not required.";
end;
Self.as_Observer.rid (the_Response'unchecked_Access,
to_Kind (chat.Client.Message'Tag),
other_Client_Name);
put_Line (other_Client_Name & " leaves.");
end deregister_Client;
overriding
procedure Registrar_has_shutdown (Self : in out Item)
is
use ada.Text_IO;
begin
put_Line ("The Registrar has shutdown. Press <Enter> to exit.");
Self.Registrar_has_shutdown := True;
end Registrar_has_shutdown;
task check_Registrar_lives
is
entry start (Self : in chat.Client.local.view);
entry halt;
end check_Registrar_lives;
task body check_Registrar_lives
is
use ada.Text_IO;
Done : Boolean := False;
Self : chat.Client.local.view;
begin
loop
select
accept start (Self : in chat.Client.local.view)
do
check_Registrar_lives.Self := Self;
end start;
or
accept halt
do
Done := True;
end halt;
or
delay 15.0;
end select;
exit when Done;
begin
chat.Registrar.ping;
exception
when system.RPC.communication_Error =>
put_Line ("The Registrar has died. Press <Enter> to exit.");
Self.Registrar_is_dead := True;
end;
end loop;
exception
when E : others =>
new_Line;
put_Line ("Error in check_Registrar_lives task.");
new_Line;
put_Line (ada.exceptions.exception_Information (E));
end check_Registrar_lives;
procedure start (Self : in out chat.Client.local.item)
is
use ada.Text_IO;
begin
-- Setup
--
begin
chat.Registrar.register (Self'unchecked_Access); -- Register our client with the registrar.
exception
when chat.Registrar.Name_already_used =>
put_Line (+Self.Name & " is already in use.");
check_Registrar_lives.halt;
return;
end;
lace.Event.utility.use_text_Logger ("events");
check_Registrar_lives.start (Self'unchecked_Access);
declare
Peers : constant chat.Client.views := chat.Registrar.all_Clients;
begin
for i in Peers'Range
loop
if Self'unchecked_Access /= Peers (i)
then
begin
Peers (i).register_Client (Self'unchecked_Access); -- Register our client with all other clients.
Self .register_Client (Peers (i)); -- Register all other clients with our client.
exception
when system.RPC.communication_Error
| storage_Error =>
null; -- Peer (i) has died, so ignore it and do nothing.
end;
end if;
end loop;
end;
-- Main loop
--
loop
declare
procedure broadcast (the_Text : in String)
is
the_Message : constant chat.Client.Message := (Length (Self.Name) + 2 + the_Text'Length,
+Self.Name & ": " & the_Text);
begin
Self.emit (the_Message);
end broadcast;
chat_Message : constant String := get_Line;
begin
exit
when chat_Message = "q"
or Self.Registrar_has_shutdown
or Self.Registrar_is_dead;
broadcast (chat_Message);
end;
end loop;
-- Shutdown
--
if not Self.Registrar_has_shutdown
and not Self.Registrar_is_dead
then
begin
chat.Registrar.deregister (Self'unchecked_Access);
exception
when system.RPC.communication_Error =>
Self.Registrar_is_dead := True;
end;
if not Self.Registrar_is_dead
then
declare
Peers : constant chat.Client.views := chat.Registrar.all_Clients;
begin
for i in Peers'Range
loop
if Self'unchecked_Access /= Peers (i)
then
begin
Peers (i).deregister_Client ( Self'unchecked_Access, -- Deregister our client with every other client.
+Self.Name);
exception
when system.RPC.communication_Error
| storage_Error =>
null; -- Peer is dead, so do nothing.
end;
end if;
end loop;
end;
end if;
end if;
check_Registrar_lives.halt;
lace.Event.utility.close;
end start;
-- 'last_chance_Handler' is commented out to avoid multiple definitions
-- of link symbols in 'build_All' test procedure (Tier 5).
--
-- procedure last_chance_Handler (Msg : in system.Address;
-- Line : in Integer);
--
-- pragma Export (C, last_chance_Handler,
-- "__gnat_last_chance_handler");
--
-- procedure last_chance_Handler (Msg : in System.Address;
-- Line : in Integer)
-- is
-- pragma Unreferenced (Msg, Line);
-- use ada.Text_IO;
-- begin
-- put_Line ("The Registrar is not running.");
-- put_Line ("Press Ctrl-C to quit.");
-- check_Registrar_lives.halt;
-- delay Duration'Last;
-- end last_chance_Handler;
end chat.Client.local;

68
1-base/lace/applet/demo/event/distributed/source/chat-client-local.ads Normal file
View File

@@ -0,0 +1,68 @@
with
lace.Any;
private
with
lace.make_Subject,
lace.make_Observer,
ada.Strings.unbounded;
package chat.Client.local
--
-- Provides a local client.
-- Names must be unique.
--
is
type Item is limited new lace.Any.limited_item
and chat.Client .item with private;
type View is access all Item'Class;
-- Forge
--
function to_Client (Name : in String) return Item;
-- Attributes
--
overriding
function Name (Self : in Item) return String;
overriding
function as_Observer (Self : access Item) return lace.Observer.view;
overriding
function as_Subject (Self : access Item) return lace.Subject.view;
-- Operations
--
procedure start (Self : in out chat.Client.local.item);
overriding
procedure register_Client (Self : in out Item; other_Client : in Client.view);
overriding
procedure deregister_Client (Self : in out Item; other_Client_as_Observer : in lace.Observer.view;
other_Client_Name : in String);
overriding
procedure Registrar_has_shutdown (Self : in out Item);
private
package Observer is new lace.make_Observer (lace.Any.limited_item);
package Subject is new lace.make_Subject (Observer .item);
use ada.Strings.unbounded;
type Item is limited new Subject .item
and chat.Client.item with
record
Name : unbounded_String;
Registrar_has_shutdown : Boolean := False;
Registrar_is_dead : Boolean := False;
end record;
end chat.Client.local;

43
1-base/lace/applet/demo/event/distributed/source/chat-client.ads Normal file
View File

@@ -0,0 +1,43 @@
with
lace.Event,
lace.Subject,
lace.Observer;
package chat.Client
--
-- Provides an interface to a chat client.
--
is
pragma remote_Types;
type Item is limited interface
and lace.Subject .item
and lace.Observer.item;
type View is access all Item'Class;
type Views is array (Positive range <>) of View;
procedure Registrar_has_shutdown (Self : in out Item) is abstract;
procedure ping (Self : in Item) is null;
procedure register_Client (Self : in out Item; other_Client : in Client.view) is abstract;
procedure deregister_Client (Self : in out Item; other_Client_as_Observer : in lace.Observer.view;
other_Client_Name : in String) is abstract;
--
-- Raises unknown_Client exception when the other_Client is unknown.
function as_Observer (Self : access Item) return lace.Observer.view is abstract;
function as_Subject (Self : access Item) return lace.Subject .view is abstract;
type Message (Length : Natural) is new lace.Event.item with
record
Text : String (1..Length);
end record;
unknown_Client : exception;
end chat.Client;

249
1-base/lace/applet/demo/event/distributed/source/chat-registrar.adb Normal file
View File

@@ -0,0 +1,249 @@
with
lace.Observer,
system.RPC,
ada.Exceptions,
ada.Strings.unbounded,
ada.Text_IO;
package body chat.Registrar
is
use ada.Strings.unbounded;
use type Client.view;
procedure last_chance_Handler (Msg : in system.Address;
Line : in Integer);
pragma Export (C, last_chance_Handler,
"__gnat_last_chance_handler");
procedure last_chance_Handler (Msg : in System.Address;
Line : in Integer)
is
pragma Unreferenced (Msg, Line);
use ada.Text_IO;
begin
put_Line ("Unable to start the Registrar.");
put_Line ("Please ensure the 'po_cos_naming' server is running.");
put_Line ("Press Ctrl-C to quit.");
delay Duration'Last;
end last_chance_Handler;
type client_Info is
record
View : Client.view;
Name : unbounded_String;
as_Observer : lace.Observer.view;
end record;
type client_Info_array is array (Positive range <>) of client_Info;
max_Clients : constant := 5_000;
-- Protection against race conditions.
--
protected safe_Clients
is
procedure add (the_Client : in Client.view);
procedure rid (the_Client : in Client.view);
function all_client_Info return client_Info_array;
private
Clients : client_Info_array (1 .. max_Clients);
end safe_Clients;
protected body safe_Clients
is
procedure add (the_Client : in Client.view)
is
function "+" (From : in String) return unbounded_String
renames to_unbounded_String;
begin
for i in Clients'Range
loop
if Clients (i).View = null then
Clients (i).View := the_Client;
Clients (i).Name := +the_Client.Name;
Clients (i).as_Observer := the_Client.as_Observer;
return;
end if;
end loop;
end add;
procedure rid (the_Client : in Client.view)
is
begin
for i in Clients'Range
loop
if Clients (i).View = the_Client then
Clients (i).View := null;
return;
end if;
end loop;
raise Program_Error with "Unknown client";
end rid;
function all_client_Info return client_Info_array
is
Count : Natural := 0;
Result : client_Info_array (1..max_Clients);
begin
for i in Clients'Range
loop
if Clients (i).View /= null
then
Count := Count + 1;
Result (Count) := Clients (i);
end if;
end loop;
return Result (1..Count);
end all_client_Info;
end safe_Clients;
procedure register (the_Client : in Client.view)
is
Name : constant String := the_Client.Name;
all_Info : constant client_Info_array := safe_Clients.all_client_Info;
begin
for Each of all_Info
loop
if Each.Name = Name
then
raise Name_already_used;
end if;
end loop;
safe_Clients.add (the_Client);
end register;
procedure deregister (the_Client : in Client.view)
is
begin
safe_Clients.rid (the_Client);
end deregister;
function all_Clients return chat.Client.views
is
all_Info : constant client_Info_array := safe_Clients.all_client_Info;
Result : chat.Client.views (all_Info'Range);
begin
for i in Result'Range
loop
Result (i) := all_Info (i).View;
end loop;
return Result;
end all_Clients;
task check_Client_lives
is
entry halt;
end check_Client_lives;
task body check_Client_lives
is
use ada.Text_IO;
Done : Boolean := False;
begin
loop
select
accept halt
do
Done := True;
end halt;
or
delay 15.0;
end select;
exit when Done;
declare
all_Info : constant client_Info_array := safe_Clients.all_client_Info;
Dead : client_Info_array (all_Info'Range);
dead_Count : Natural := 0;
function "+" (From : in unbounded_String) return String
renames to_String;
begin
for Each of all_Info
loop
begin
Each.View.ping;
exception
when system.RPC.communication_Error
| storage_Error =>
put_Line (+Each.Name & " has died.");
deregister (Each.View);
dead_Count := dead_Count + 1;
Dead (dead_Count) := Each;
end;
end loop;
declare
all_Clients : constant Client.views := chat.Registrar.all_Clients;
begin
for Each of all_Clients
loop
for i in 1 .. dead_Count
loop
begin
put_Line ("Ridding " & (+Dead (i).Name) & " from " & Each.Name);
Each.deregister_Client ( Dead (i).as_Observer,
+Dead (i).Name);
exception
when chat.Client.unknown_Client =>
put_Line ("Deregister of " & (+Dead (i).Name) & " from " & Each.Name & " is not needed.");
end;
end loop;
end loop;
end;
end;
end loop;
exception
when E : others =>
new_Line;
put_Line ("Error in check_Client_lives task.");
new_Line;
put_Line (ada.Exceptions.exception_Information (E));
end check_Client_lives;
procedure shutdown
is
all_Clients : constant Client.views := chat.Registrar.all_Clients;
begin
for Each of all_Clients
loop
begin
Each.Registrar_has_shutdown;
exception
when system.RPC.communication_Error =>
null; -- Client has died. No action needed since we are shutting down.
end;
end loop;
check_Client_lives.halt;
end shutdown;
procedure ping is null;
end chat.Registrar;

22
1-base/lace/applet/demo/event/distributed/source/chat-registrar.ads Normal file
View File

@@ -0,0 +1,22 @@
with
chat.Client;
package chat.Registrar
--
-- A singleton providing the central chat registrar.
-- Limited to a maximum of 5_000 chat clients running at once.
--
is
pragma remote_Call_interface;
Name_already_used : exception;
procedure register (the_Client : in Client.view);
procedure deregister (the_Client : in Client.view);
function all_Clients return chat.Client.views;
procedure ping;
procedure shutdown;
end chat.Registrar;

7
1-base/lace/applet/demo/event/distributed/source/chat.ads Normal file
View File

@@ -0,0 +1,7 @@
package Chat
--
-- Provides a namespace for the chat family.
--
is
pragma Pure;
end Chat;

18
1-base/lace/applet/demo/event/distributed/test/lan/README Normal file
View File

@@ -0,0 +1,18 @@
Edit /etc/hosts to force usage of 127.0.0.1 by po_cos_naming.
For instance, given ...
/etc/hostname
foo
/etc/hosts
127.0.0.1 localhost
192.168.1.10 foo.mydomain.org foo
... change to ...
/etc/hosts
127.0.0.1 localhost
# 192.168.1.10 foo.mydomain.org foo

12
1-base/lace/applet/demo/event/distributed/test/lan/client_1/polyorb.conf Normal file
View File

@@ -0,0 +1,12 @@
# PolyORB configuration file for the chat Client_1.
[dsa]
name_service=corbaloc:iiop:1.2@127.0.0.1:5001/NameService/000000024fF0000000080000000
[iiop]
## IIOP default port
#
polyorb.protocols.iiop.default_port=5003

5
1-base/lace/applet/demo/event/distributed/test/lan/client_1/test.sh Executable file
View File

@@ -0,0 +1,5 @@
#!/bin/bash
set -e
../../../bin/client_partition rod

12
1-base/lace/applet/demo/event/distributed/test/lan/client_2/polyorb.conf Normal file
View File

@@ -0,0 +1,12 @@
# PolyORB configuration file for the chat Client_2.
[dsa]
name_service=corbaloc:iiop:1.2@127.0.0.1:5001/NameService/000000024fF0000000080000000
[iiop]
## IIOP default port
#
polyorb.protocols.iiop.default_port=5004

5
1-base/lace/applet/demo/event/distributed/test/lan/client_2/test.sh Executable file
View File

@@ -0,0 +1,5 @@
#!/bin/bash
set -e
../../../bin/client_partition ian

7
1-base/lace/applet/demo/event/distributed/test/lan/po_namer/polyorb.conf Normal file
View File

@@ -0,0 +1,7 @@
# PolyORB configuration file for polyorb cos name server.
[iiop]
## IIOP default port
#
polyorb.protocols.iiop.default_port=5001

5
1-base/lace/applet/demo/event/distributed/test/lan/po_namer/test.sh Executable file
View File

@@ -0,0 +1,5 @@
#!/bin/bash
set -e
po_cos_naming

12
1-base/lace/applet/demo/event/distributed/test/lan/registrar/polyorb.conf Normal file
View File

@@ -0,0 +1,12 @@
# PolyORB configuration file for the chat Registrar server.
[dsa]
name_service=corbaloc:iiop:1.2@127.0.0.1:5001/NameService/000000024fF0000000080000000
[iiop]
## IIOP default port
#
polyorb.protocols.iiop.default_port=5002

5
1-base/lace/applet/demo/event/distributed/test/lan/registrar/test.sh Executable file
View File

@@ -0,0 +1,5 @@
#!/bin/bash
set -e
../../../bin/registrar_partition

12
1-base/lace/applet/demo/event/distributed/test/wan/client_1/polyorb.conf Normal file
View File

@@ -0,0 +1,12 @@
# PolyORB configuration file for the chat Client_1.
[dsa]
name_service=corbaloc:iiop:1.2@127.0.0.1:5001/NameService/000000024fF0000000080000000
[iiop]
## IIOP default port
#
polyorb.protocols.iiop.default_port=5003

12
1-base/lace/applet/demo/event/distributed/test/wan/client_2/polyorb.conf Normal file
View File

@@ -0,0 +1,12 @@
# PolyORB configuration file for the chat Client_2.
[dsa]
name_service=corbaloc:iiop:1.2@127.0.0.1:5001/NameService/000000024fF0000000080000000
[iiop]
## IIOP default port
#
polyorb.protocols.iiop.default_port=5004

7
1-base/lace/applet/demo/event/distributed/test/wan/po_namer/polyorb.conf Normal file
View File

@@ -0,0 +1,7 @@
# PolyORB configuration file for polyorb cos name server.
[iiop]
## IIOP default port
#
polyorb.protocols.iiop.default_port=5001

12
1-base/lace/applet/demo/event/distributed/test/wan/registrar/polyorb.conf Normal file
View File

@@ -0,0 +1,12 @@
# PolyORB configuration file for the chat Registrar server.
[dsa]
name_service=corbaloc:iiop:1.2@127.0.0.1:5001/NameService/000000024fF0000000080000000
[iiop]
## IIOP default port
#
polyorb.protocols.iiop.default_port=5002

27
1-base/lace/applet/demo/event/simple/deferred/lace_simple_deferred_events_demo.gpr Normal file
View File

@@ -0,0 +1,27 @@
with
"../lace_demo",
"lace",
"lace_shared";
project lace_simple_deferred_Events_Demo
is
type Restrictions is ("xgc", "ravenscar");
Restrictions : Restrictions := external ("restrictions");
for Create_Missing_Dirs use "True";
for Object_Dir use "build";
for Exec_Dir use ".";
for Source_Dirs use (".");
for Main use ("launch_simple_deferred_events_demo.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;
package Linker is
for Default_Switches ("ada") use ("-g");
end Linker;
end lace_simple_deferred_Events_Demo;

81
1-base/lace/applet/demo/event/simple/deferred/launch_simple_deferred_events_demo.adb Normal file
View File

@@ -0,0 +1,81 @@
with
lace_demo_Events,
lace_demo_Keyboard,
lace.Observer.deferred,
lace.Subject .local,
lace.Response,
lace.Event.utility,
ada.Text_IO,
ada.Strings.unbounded,
ada.real_Time;
procedure launch_simple_deferred_events_Demo
--
-- A simple demonstration of the Lace deferred event system.
--
is
use lace_demo_Events,
lace.Event,
lace.event.Utility,
Lace,
ada.text_IO,
ada.Strings.unbounded,
ada.real_Time;
-- Key Response
--
type key_Map_of_message is array (Character) of unbounded_String;
type key_Response is new Response.item with
record
key_to_message_Map : key_Map_of_message;
end record;
overriding
procedure respond (Self : in out key_Response; to_Event : in Event.item'Class)
is
the_Event : keyboard_Event renames keyboard_Event (to_Event);
begin
put_Line ( "Message is: " -- Our response is to display the message associated
& to_String (Self.key_to_message_Map (the_Event.Key))); -- with the keyboard event key on the console.
end respond;
--- Globals
--
the_Subject : Subject.local.view;
the_Observer : constant Observer.deferred.view := Observer.deferred.forge.new_Observer ("demo.Observer");
the_Response : aliased key_Response := (Response.item with
key_to_message_Map => ['a' => to_unbounded_String ("'a' was received from demo keyboard."),
'b' => to_unbounded_String ("'b' was received from demo keyboard."),
others => to_unbounded_String ("Unhandled key was received from demo keyboard.")]);
Now : ada.real_Time.Time := ada.real_Time.Clock;
begin
Event.utility.use_text_Logger (log_filename => "events_demo"); -- Enable 'simple text file' event logging.
the_Subject := lace_demo_Keyboard.as_event_Subject; -- Get a reference to the keyboard as an event subject.
Event.utility.connect (the_observer => Observer.view (the_Observer), -- Setup out response to a keyboard event.
to_subject => Subject .view (the_Subject),
with_response => the_Response'unchecked_Access,
to_event_kind => to_Kind (keyboard_Event'Tag));
lace_demo_Keyboard.start;
for Each in 1 .. 5
loop -- Our main loop.
the_Observer.respond; -- Response to any queued events occur here.
Now := Now + to_time_Span (1.0);
delay until Now;
end loop;
lace_demo_Keyboard.stop;
Event.utility.close; -- Ensures event logging is closed (ie saved to log file).
end launch_simple_deferred_events_Demo;

27
1-base/lace/applet/demo/event/simple/instant/lace_simple_instant_events_demo.gpr Normal file
View File

@@ -0,0 +1,27 @@
with
"../lace_demo",
"lace",
"lace_shared";
project lace_simple_instant_Events_Demo
is
type Restrictions is ("xgc", "ravenscar");
Restrictions : Restrictions := external ("restrictions");
for Create_Missing_Dirs use "True";
for Object_Dir use "build";
for Exec_Dir use ".";
for Source_Dirs use (".");
for Main use ("launch_simple_instant_events_demo.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;
package Linker is
for Default_Switches ("ada") use ("-g");
end Linker;
end lace_simple_instant_Events_Demo;

80
1-base/lace/applet/demo/event/simple/instant/launch_simple_instant_events_demo.adb Normal file
View File

@@ -0,0 +1,80 @@
with
lace_demo_Events,
lace_demo_Keyboard,
lace.Observer.instant,
lace.Subject .local,
lace.Response,
lace.Event.utility,
ada.Text_IO,
ada.Strings.unbounded,
ada.real_Time;
procedure launch_simple_instant_events_Demo
--
-- A simple demonstration of the Lace event system.
--
is
use lace_demo_Events,
Lace,
lace.Event,
lace.event.Utility,
ada.Text_IO,
ada.Strings.unbounded,
ada.real_Time;
-- key_Response
--
type key_Map_of_message is array (Character) of unbounded_String;
type key_Response is new Response.item with
record
key_to_message_Map : key_Map_of_message;
end record;
overriding
procedure respond (Self : in out key_Response; to_Event : in Event.item'Class)
is
the_Event : keyboard_Event renames keyboard_Event (to_Event);
begin
put_Line ( "Message is: " -- Our response is to display the message associated
& to_String (Self.key_to_message_Map (the_Event.Key))); -- with the keyboard event key on the console.
end respond;
-- Globals
--
the_Subject : Subject.local.view;
the_Observer : constant Observer.instant.view := Observer.instant.forge.new_Observer ("demo.Observer");
the_Response : aliased key_Response := (Response.item with
key_to_message_Map => ['a' => to_unbounded_String ("'a' was received from demo keyboard."),
'b' => to_unbounded_String ("'b' was received from demo keyboard."),
others => to_unbounded_String ("Unhandled key was received from demo keyboard.")]);
Now : ada.real_Time.Time := ada.real_Time.Clock;
begin
event.Utility.use_text_Logger (log_filename => "events_demo"); -- Enable simple text file event logging.
the_Subject := lace_demo_Keyboard.as_event_Subject; -- Get a reference to the keyboard as an event subject.
event.Utility.connect (the_observer => Observer.view (the_Observer), -- Setup our response to a keyboard event.
to_subject => Subject .view (the_Subject),
with_response => the_Response'unchecked_Access,
to_event_kind => to_Kind (keyboard_Event'Tag));
lace_demo_Keyboard.start;
for Each in 1 .. 5
loop -- Our main loop.
Now := Now + to_time_Span (1.0);
delay until Now;
end loop;
lace_demo_Keyboard.stop;
event.Utility.close; -- Ensure event logging is closed (ie saved to log file).
end launch_simple_instant_events_Demo;

24
1-base/lace/applet/demo/event/simple/lace_demo.gpr Normal file
View File

@@ -0,0 +1,24 @@
with
"lace",
"lace_shared";
project lace_Demo
is
type Restrictions is ("xgc", "ravenscar");
Restrictions : Restrictions := external ("restrictions");
for Create_Missing_Dirs use "True";
for Object_Dir use "build";
for Source_Dirs use (".");
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 Default_Switches ("ada") use ("-g");
end Linker;
end lace_Demo;

16
1-base/lace/applet/demo/event/simple/lace_demo_events.ads Normal file
View File

@@ -0,0 +1,16 @@
with
lace.Event;
package lace_demo_Events
--
-- Provides a simple derived lace 'event'.
--
is
pragma remote_Types;
type keyboard_Event is new lace.Event.item with
record
Key : Character;
end record;
end lace_demo_Events;

77
1-base/lace/applet/demo/event/simple/lace_demo_keyboard.adb Normal file
View File

@@ -0,0 +1,77 @@
with
lace_demo_Events,
ada.real_Time;
package body lace_demo_Keyboard
is
use lace_demo_Events,
Lace,
ada.real_Time;
--- Simulated Keyboard
--
the_event_Subject : constant Subject.local.view := Subject.local.forge.new_Subject ("demo.Subject");
task type simulated_Keyboard
is
entry start;
entry stop;
end simulated_Keyboard;
task body simulated_Keyboard
is
Count : Natural := 0;
Now : ada.real_Time.Time := ada.real_Time.Clock;
Done : Boolean := False;
begin
accept start;
loop
select
accept stop
do
Done := True;
end stop;
or
delay until Now;
end select;
exit when Done;
if Count mod 3 = 0
then
the_event_Subject.emit (the_Event => keyboard_Event'(key => 'a'));
else
the_event_Subject.emit (the_Event => keyboard_Event'(key => 'b'));
end if;
Count := Count + 1;
Now := Now + to_time_Span (0.5);
end loop;
end simulated_Keyboard;
the_simulated_Keyboard : simulated_Keyboard;
function as_event_Subject return lace.Subject.local.view
is
begin
return the_event_Subject;
end as_event_Subject;
procedure start
is
begin
the_simulated_Keyboard.start;
end start;
procedure stop
is
begin
the_simulated_Keyboard.stop;
end stop;
end lace_demo_Keyboard;

14
1-base/lace/applet/demo/event/simple/lace_demo_keyboard.ads Normal file
View File

@@ -0,0 +1,14 @@
with
lace.Subject.local;
package lace_demo_Keyboard
--
-- Provides a simulated keyboard which periodically emits 'key' events.
--
is
function as_event_Subject return lace.Subject.local.view;
procedure start;
procedure stop;
end lace_demo_Keyboard;

20
1-base/lace/applet/demo/strings/launch_strings_demo.adb Normal file
View File

@@ -0,0 +1,20 @@
with
lace.Strings.bounded,
ada.Text_IO;
procedure launch_strings_Demo
--
-- Displays a string message in a Pure unit.
--
is
use ada.Text_IO;
package Text is new lace.Strings.Bounded.Generic_Bounded_Length (Max => 64);
use Text;
the_String : bounded_String := to_bounded_String ("Howdy ...");
begin
append (the_String, " doody !");
put_Line (to_String (the_String));
end launch_strings_Demo;

25
1-base/lace/applet/demo/strings/strings_demo.gpr Normal file
View File

@@ -0,0 +1,25 @@
with "lace";
project Strings_Demo
is
for Object_Dir use "build";
for Exec_Dir use ".";
for Main use ("launch_strings_demo.adb");
package Builder is
for Default_Switches ("ada") use ("-g");
end Builder;
package Compiler is
for Default_Switches ("ada") use ("-gnato", "-fstack-check", "-g", "-gnata", "-gnat2022");
end Compiler;
package Binder is
for Default_Switches ("ada") use ("-E");
end Binder;
package Linker is
for Default_Switches ("ada") use ("-g");
end Linker;
end Strings_Demo;

74
1-base/lace/applet/test/dice/test_dice.adb Normal file
View File

@@ -0,0 +1,74 @@
with
lace.Dice.d6,
lace.Dice.any,
ada.Text_IO;
procedure test_Dice
is
procedure log (Message : in String) renames ada.Text_IO.put_Line;
test_Error : exception;
begin
log ("Begin Test");
-- d6x1
--
log ("");
log ("d6x1_less5 Roll:" & lace.Dice.d6.d6x1_less5.Roll'Image);
log ("d6x1_less4 Roll:" & lace.Dice.d6.d6x1_less4.Roll'Image);
log ("d6x1_less3 Roll:" & lace.Dice.d6.d6x1_less3.Roll'Image);
log ("d6x1_less2 Roll:" & lace.Dice.d6.d6x1_less2.Roll'Image);
log ("d6x1_less1 Roll:" & lace.Dice.d6.d6x1_less1.Roll'Image);
log ("d6x1 Roll:" & lace.Dice.d6.d6x1 .Roll'Image);
log ("d6x1_plus1 Roll:" & lace.Dice.d6.d6x1_plus1.Roll'Image);
log ("d6x1_plus2 Roll:" & lace.Dice.d6.d6x1_plus2.Roll'Image);
-- d6x2
--
log ("");
log ("d6x2_less1 Roll:" & lace.Dice.d6.d6x2_less1.Roll'Image);
log ("d6x2 Roll:" & lace.Dice.d6.d6x2 .Roll'Image);
log ("d6x2_plus1 Roll:" & lace.Dice.d6.d6x2_plus1.Roll'Image);
log ("d6x2_plus2 Roll:" & lace.Dice.d6.d6x2_plus2.Roll'Image);
-- any
--
declare
use lace.Dice,
lace.Dice.any;
d100 : constant lace.Dice.any.item := to_Dice (Sides => 100,
Rolls => 1,
Modifier => 0);
the_Roll : Natural;
one_Count : Natural := 0;
hundred_Count : Natural := 0;
begin
for i in 1 .. 1_000
loop
the_Roll := d100.Roll;
case the_Roll
is
when 0 => raise test_Error with "Roll was 0.";
when 1 => one_Count := one_Count + 1;
when 100 => hundred_Count := hundred_Count + 1;
when 101 => raise test_Error with "Roll was 101.";
when others => null;
end case;
end loop;
log ("");
log ("1 rolled" & one_Count'Image & " times.");
log ("100 rolled" & hundred_Count'Image & " times.");
end;
log ("");
log ("End Test");
end test_Dice;

19
1-base/lace/applet/test/dice/test_dice.gpr Normal file
View File

@@ -0,0 +1,19 @@
with
"lace",
"lace_shared";
project test_Dice
is
for Object_Dir use "build";
for Exec_Dir use ".";
for Main use ("test_dice.adb");
package Builder renames Lace_shared.Builder;
package Compiler renames Lace_shared.Compiler;
package Binder renames Lace_shared.Binder;
package Linker is
for Default_Switches ("ada") use ("-g");
end Linker;
end test_Dice;

67
1-base/lace/applet/test/environ/compression/test_environ_compression.adb Normal file
View File

@@ -0,0 +1,67 @@
with
lace.Environ,
ada.Text_IO;
procedure test_Environ_compression
is
use lace.Environ,
ada.Text_IO;
test_Error : exception;
digits_Text : constant String := "0123456789";
begin
put_Line ("Begin");
verify_Folder ("tmp");
goto_Folder ("tmp");
--- Compress single files.
--
save (digits_Text, "digits.txt-original");
copy_File ("digits.txt-original", "digits.txt");
for Each in compress_Format
loop
compress ("digits.txt", Each);
rid_File ("digits.txt");
decompress ("digits.txt" & format_Suffix (Each));
if load ("digits.txt") /= digits_Text
then
raise test_Error with "'" & load ("digits.txt") & "'";
end if;
rid_File ("digits.txt" & format_Suffix (Each));
end loop;
--- Compress directories.
--
verify_Folder ("archive-original");
move_Files ("*", "archive-original");
copy_Folder ("archive-original", "archive");
for Each in folder_compress_Format
loop
compress ("archive", Each);
rid_Folder ("archive");
decompress ("archive" & format_Suffix (Each));
if load ("archive/digits.txt")
/= load ("archive-original/digits.txt")
then
raise test_Error with "'" & load ("archive/digits.txt") & "'";
end if;
rid_File ("archive" & format_Suffix (Each));
end loop;
--- Tidy up
--
goto_Folder ("..");
rid_Folder ("tmp");
put_Line ("Success");
end test_Environ_compression;

19
1-base/lace/applet/test/environ/compression/test_environ_compression.gpr Normal file
View File

@@ -0,0 +1,19 @@
with
"lace",
"lace_shared";
project test_Environ_compression
is
for Object_Dir use "build";
for Exec_Dir use ".";
for Main use ("test_environ_compression.adb");
package Builder renames Lace_shared.Builder;
package Compiler renames Lace_shared.Compiler;
package Binder renames Lace_shared.Binder;
package Linker is
for Default_Switches ("ada") use ("-g");
end Linker;
end test_Environ_compression;

0
1-base/lace/applet/test/environ/general/data/glob1.txt Normal file
View File

0
1-base/lace/applet/test/environ/general/data/glob2.txt Normal file
View File

0
1-base/lace/applet/test/environ/general/data/glob3.txt Normal file
View File

27
1-base/lace/applet/test/environ/general/test_environ_general.adb Normal file
View File

@@ -0,0 +1,27 @@
with
lace.Environ,
ada.Text_IO;
procedure test_Environ_general
is
use lace.Environ,
ada.Text_IO;
Error : exception;
begin
put_Line ("Begin");
-- Test GLOB expansion.
--
declare
Output : constant String := expand_GLOB ("data/*.txt");
begin
if Output /= "data/glob1.txt data/glob2.txt data/glob3.txt"
then
raise Error with "expand_GLOB fails: '" & Output & "'";
end if;
end;
put_Line ("Success");
put_Line ("End");
end test_Environ_general;

19
1-base/lace/applet/test/environ/general/test_environ_general.gpr Normal file
View File

@@ -0,0 +1,19 @@
with
"lace",
"lace_shared";
project test_Environ_general
is
for Object_Dir use "build";
for Exec_Dir use ".";
for Main use ("test_environ_general.adb");
package Builder renames Lace_shared.Builder;
package Compiler renames Lace_shared.Compiler;
package Binder renames Lace_shared.Binder;
package Linker is
for Default_Switches ("ada") use ("-g");
end Linker;
end test_Environ_general;

1
1-base/lace/applet/test/environ/paths/data/digits.txt Normal file
View File

@@ -0,0 +1 @@
0123456789

0
1-base/lace/applet/test/environ/paths/data/empty.txt Normal file
View File

38
1-base/lace/applet/test/environ/paths/test_environ_paths.adb Normal file
View File

@@ -0,0 +1,38 @@
with
lace.Environ.Paths,
ada.Text_IO;
procedure test_Environ_Paths
is
use lace.Environ.Paths,
ada.Text_IO;
Error : exception;
begin
put_Line ("Begin");
-- Test load of an empty file.
--
declare
Output : constant String := to_File ("data/empty.txt").load;
begin
if Output /= ""
then
raise Error with "Loading an empty file fails: '" & Output & "'";
end if;
end;
-- Test load of simple text.
--
declare
Output : constant String := to_File ("data/digits.txt").load;
begin
if Output /= "0123456789"
then
raise Error with "Loading a simple text file fails: '" & Output & "'";
end if;
end;
put_Line ("Success");
put_Line ("End");
end test_Environ_Paths;

19
1-base/lace/applet/test/environ/paths/test_environ_paths.gpr Normal file
View File

@@ -0,0 +1,19 @@
with
"lace",
"lace_shared";
project test_Environ_Paths
is
for Object_Dir use "build";
for Exec_Dir use ".";
for Main use ("test_environ_paths.adb");
package Builder renames Lace_shared.Builder;
package Compiler renames Lace_shared.Compiler;
package Binder renames Lace_shared.Binder;
package Linker is
for Default_Switches ("ada") use ("-g");
end Linker;
end test_Environ_Paths;

19
1-base/lace/applet/test/text/test_text.gpr Normal file
View File

@@ -0,0 +1,19 @@
with
"lace",
"lace_shared";
project test_Text
is
for Object_Dir use "build";
for Exec_Dir use ".";
for Main use ("test_text_replace.adb");
package Builder renames Lace_shared.Builder;
package Compiler renames Lace_shared.Compiler;
package Binder renames Lace_shared.Binder;
package Linker is
for Default_Switches ("ada") use ("-g");
end Linker;
end test_Text;

221
1-base/lace/applet/test/text/test_text_replace.adb Normal file
View File

@@ -0,0 +1,221 @@
with
lace.Text.utility,
ada.Text_IO;
procedure test_Text_replace
is
use lace.Text,
lace.Text.utility,
ada.Text_IO;
test_Error : exception;
begin
put_Line ("Begin Test");
new_Line;
-- Test 'replace' function.
--
declare
Initial : aliased constant lace.Text.item := to_Text ("<TOKEN>");
Final : constant String := +replace (Initial, "<TOKEN>", "");
begin
if Final /= ""
then
raise test_Error with "replace fails: Initial => '" & (+Initial) & "' "
& "Final => '" & Final & "'";
end if;
end;
declare
Initial : aliased constant lace.Text.item := to_Text ("<TOKEN>");
Final : constant String := +replace (Initial, "<TOKEN>", "Linux");
begin
if Final /= "Linux"
then
raise test_Error with "replace fails: Initial => '" & (+Initial) & "' "
& "Final => '" & Final & "'";
end if;
end;
declare
Initial : aliased constant lace.Text.item := to_Text ("123<TOKEN>456");
Final : constant String := +replace (Initial, "<TOKEN>", "Linux");
begin
if Final /= "123Linux456"
then
raise test_Error with "replace fails: Initial => '" & (+Initial) & "' "
& "Final => '" & Final & "'";
end if;
end;
declare
Initial : aliased constant lace.Text.item := to_Text ("123<TOKEN>");
Final : constant String := +replace (Initial, "<TOKEN>", "Linux");
begin
if Final /= "123Linux"
then
raise test_Error with "replace fails: Initial => '" & (+Initial) & "' "
& "Final => '" & Final & "'";
end if;
end;
declare
Initial : aliased constant lace.Text.item := to_Text ("<TOKEN>456");
Final : constant String := +replace (Initial, "<TOKEN>", "Linux");
begin
if Final /= "Linux456"
then
raise test_Error with "replace fails: Initial => '" & (+Initial) & "' "
& "Final => '" & Final & "'";
end if;
end;
declare
Initial : aliased constant lace.Text.item := to_Text ("<TOKEN>123<TOKEN>");
Final : constant String := +replace (Initial, "<TOKEN>", "Linux");
begin
if Final /= "Linux123Linux"
then
raise test_Error with "replace fails: Initial => '" & (+Initial) & "' "
& "Final => '" & Final & "'";
end if;
end;
declare
Initial : aliased constant lace.Text.item := to_Text ("<TOKEN><TOKEN>");
Final : constant String := +replace (Initial, "<TOKEN>", "Linux");
begin
if Final /= "LinuxLinux"
then
raise test_Error with "replace fails: Initial => '" & (+Initial) & "' "
& "Final => '" & Final & "'";
end if;
end;
declare
Initial : aliased constant lace.Text.item := to_Text ("<TOKEN>", capacity => 64);
Final : constant String := +replace (Initial, "<TOKEN>", "Longish String") with Unreferenced;
begin
put_Line ("No capacity error raised, as expected.");
end;
-- Test 'replace' procedure.
--
declare
Initial : constant String := "<TOKEN>";
Text : lace.Text.item := to_Text (Initial);
begin
replace (Text, "<TOKEN>", "");
if +Text /= ""
then
raise test_Error with "replace fails: Initial => '" & Initial & "' "
& "Final => '" & (+Text) & "'";
end if;
end;
declare
Initial : constant String := "<TOKEN>";
Text : lace.Text.item := to_Text (Initial);
begin
replace (Text, "<TOKEN>", "Linux");
if +Text /= "Linux"
then
raise test_Error with "replace fails: Initial => '" & Initial & "' "
& "Final => '" & (+Text) & "'";
end if;
end;
declare
Initial : constant String := "123<TOKEN>456";
Text : lace.Text.item := to_Text (Initial);
begin
replace (Text, "<TOKEN>", "Linux");
if +Text /= "123Linux456"
then
raise test_Error with "replace fails: Initial => '" & Initial & "' "
& "Final => '" & (+Text) & "'";
end if;
end;
declare
Initial : constant String := "123<TOKEN>";
Text : lace.Text.item := to_Text (Initial);
begin
replace (Text, "<TOKEN>", "Linux");
if +Text /= "123Linux"
then
raise test_Error with "replace fails: Initial => '" & Initial & "' "
& "Final => '" & (+Text) & "'";
end if;
end;
declare
Initial : constant String := "<TOKEN>456";
Text : lace.Text.item := to_Text (Initial);
begin
replace (Text, "<TOKEN>", "Linux");
if +Text /= "Linux456"
then
raise test_Error with "replace fails: Initial => '" & Initial & "' "
& "Final => '" & (+Text) & "'";
end if;
end;
declare
Initial : constant String := "<TOKEN>123<TOKEN>";
Text : lace.Text.item := to_Text (Initial);
begin
replace (Text, "<TOKEN>", "Linux");
if +Text /= "Linux123Linux"
then
raise test_Error with "replace fails: Initial => '" & Initial & "' "
& "Final => '" & (+Text) & "'";
end if;
end;
declare
Initial : constant String := "<TOKEN><TOKEN>";
Text : lace.Text.item := to_Text (Initial);
begin
replace (Text, "<TOKEN>", "Linux");
if +Text /= "LinuxLinux"
then
raise test_Error with "replace fails: Initial => '" & Initial & "' "
& "Final => '" & (+Text) & "'";
end if;
end;
declare
Initial : constant String := "<TOKEN>";
Text : lace.Text.item := to_Text (Initial);
begin
replace (Text, "<TOKEN>", "Longish String");
exception
when lace.Text.Error =>
put_Line ("Capacity error raised, as expected.");
end;
declare
Initial : constant String := "<TOKEN>";
Text : lace.Text.item := to_Text (Initial, capacity => 64);
begin
replace (Text, "<TOKEN>", "Longish String");
put_Line ("No capacity error raised, as expected.");
end;
new_Line;
put_Line ("Success");
put_Line ("End Test");
end test_Text_replace;