mirror of
https://github.com/AdaCore/PolyORB.git
synced 2026-02-12 13:01:15 -08:00
367 lines
11 KiB
Ada
367 lines
11 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- POLYORB COMPONENTS --
|
|
-- --
|
|
-- S E R V E R --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 2002-2012, Free Software Foundation, Inc. --
|
|
-- --
|
|
-- This is free software; you can redistribute it and/or modify it under --
|
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
|
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
|
-- sion. This software 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. See the GNU General Public --
|
|
-- License for more details. --
|
|
-- --
|
|
-- 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/>. --
|
|
-- --
|
|
-- PolyORB is maintained by AdaCore --
|
|
-- (email: sales@adacore.com) --
|
|
-- --
|
|
------------------------------------------------------------------------------
|
|
|
|
with Ada.Characters.Handling; use Ada.Characters.Handling;
|
|
with Ada.Text_IO; use Ada.Text_IO;
|
|
with Exceptions; use Exceptions;
|
|
with System.RPC;
|
|
with Utils; use Utils;
|
|
|
|
package body Server is
|
|
|
|
type String_Access is access String;
|
|
|
|
type Message;
|
|
type Message_Access is access Message;
|
|
type Message is record
|
|
Sender : String_Access;
|
|
Content : String_Access;
|
|
Next_Message : Message_Access;
|
|
end record;
|
|
|
|
protected Message_Board is
|
|
|
|
procedure Add_Message
|
|
(Sender : String;
|
|
Content : String);
|
|
-- Add a message to the message board. Sender_Error and Message_Error
|
|
-- will be raised if the sender or the message are empty.
|
|
|
|
function Messages_Count return Natural;
|
|
-- Number of messages in the message board
|
|
|
|
function Get_Sender (N : Positive) return String;
|
|
-- Sender of a particular message (No_Such_Message will be raised if
|
|
-- there is no such message).
|
|
|
|
function Get_Message (N : Positive) return String;
|
|
-- Content of a particular message (No_Such_Message will be raised if
|
|
-- there is no such message).
|
|
|
|
private
|
|
|
|
function Get (N : Positive) return Message_Access;
|
|
-- Get a message, and raise No_Such_Message if it does not exist
|
|
|
|
Messages : Message_Access := null;
|
|
Count : Natural := 0;
|
|
|
|
end Message_Board;
|
|
-- Message_Board is a protected structure (we will not have concurrent
|
|
-- calls) in which messages are stored. The messages are stored in reverse
|
|
-- order. This is totally *inefficient*, but well, this is a toy program :)
|
|
|
|
type Penpal_Node;
|
|
type Penpal_List is access Penpal_Node;
|
|
type Penpal_Node is record
|
|
Name : String_Access;
|
|
Penpal : Penpal_Pointer;
|
|
Next_Penpal : Penpal_List;
|
|
end record;
|
|
|
|
type Penpal_Array is array (Positive range <>) of Penpal_Node;
|
|
-- List of penpals with their names. The Next_Penpal field will have
|
|
-- no meaning though.
|
|
|
|
protected Penpals_Handler is
|
|
|
|
procedure Add (Penpal : Penpal_Pointer);
|
|
-- Add a Penpal to the list, raise Sender_Error if the penpal has not
|
|
-- been initialized.
|
|
|
|
function Lookup (Name : String) return Penpal_Pointer;
|
|
-- Lookup a penpal in the list, or raise No_Such_Penpal if no penpal
|
|
-- by this name has been registered.
|
|
|
|
function Get_List return Penpal_Array;
|
|
-- Return the list of registered penpals
|
|
|
|
private
|
|
|
|
function Lookup (Name : String) return Penpal_List;
|
|
-- Lookup a penpal by its name, and return null if no such penpal
|
|
-- has been registered;
|
|
|
|
Penpals : Penpal_List := null;
|
|
|
|
Count : Natural := 0;
|
|
|
|
end Penpals_Handler;
|
|
|
|
---------------
|
|
-- Broadcast --
|
|
---------------
|
|
|
|
procedure Broadcast (Sender : String; Message : String) is
|
|
Penpals : constant Penpal_Array := Penpals_Handler.Get_List;
|
|
begin
|
|
Put_Line ("Sending a broadcast to " &
|
|
Integer_To_String (Penpals'Length) &
|
|
" registered clients:");
|
|
for I in Penpals'Range loop
|
|
begin
|
|
Put (" Trying to contact <" & Penpals (I).Name.all & ">... ");
|
|
Flush;
|
|
New_Message (Sender => Sender,
|
|
Recipient => Penpals (I).Penpal,
|
|
Message => Message);
|
|
Put_Line ("OK");
|
|
exception
|
|
when System.RPC.Communication_Error =>
|
|
|
|
-- This penpal is probably dead, ignore the error...
|
|
|
|
Put_Line ("fail");
|
|
end;
|
|
end loop;
|
|
end Broadcast;
|
|
|
|
-----------------
|
|
-- Get_Message --
|
|
-----------------
|
|
|
|
function Get_Message (N : Positive) return String is
|
|
begin
|
|
return Message_Board.Get_Message (N);
|
|
end Get_Message;
|
|
|
|
----------------
|
|
-- Get_Penpal --
|
|
----------------
|
|
|
|
function Get_Penpal (Name : String) return Penpal_Pointer is
|
|
begin
|
|
return Penpals_Handler.Lookup (Name);
|
|
end Get_Penpal;
|
|
|
|
----------------
|
|
-- Get_Sender --
|
|
----------------
|
|
|
|
function Get_Sender (N : Positive) return String is
|
|
begin
|
|
return Message_Board.Get_Sender (N);
|
|
end Get_Sender;
|
|
|
|
-------------------
|
|
-- Message_Board --
|
|
-------------------
|
|
|
|
protected body Message_Board is
|
|
|
|
-----------------
|
|
-- Add_Message --
|
|
-----------------
|
|
|
|
procedure Add_Message
|
|
(Sender : String;
|
|
Content : String)
|
|
is
|
|
begin
|
|
if Sender = "" then
|
|
raise Sender_Error;
|
|
elsif Content = "" then
|
|
raise Message_Error;
|
|
else
|
|
Messages := new Message'(Sender => new String'(Sender),
|
|
Content => new String'(Content),
|
|
Next_Message => Messages);
|
|
Count := Count + 1;
|
|
end if;
|
|
end Add_Message;
|
|
|
|
---------
|
|
-- Get --
|
|
---------
|
|
|
|
function Get (N : Positive) return Message_Access is
|
|
Current : Message_Access := Messages;
|
|
begin
|
|
if N > Count then
|
|
raise No_Such_Message;
|
|
end if;
|
|
for I in N + 1 .. Count loop
|
|
Current := Current.Next_Message;
|
|
end loop;
|
|
return Current;
|
|
end Get;
|
|
|
|
-----------------
|
|
-- Get_Message --
|
|
-----------------
|
|
|
|
function Get_Message (N : Positive) return String is
|
|
begin
|
|
return Get (N) .Content.all;
|
|
end Get_Message;
|
|
|
|
----------------
|
|
-- Get_Sender --
|
|
----------------
|
|
|
|
function Get_Sender (N : Positive) return String is
|
|
begin
|
|
return Get (N) .Sender.all;
|
|
end Get_Sender;
|
|
|
|
--------------------
|
|
-- Messages_Count --
|
|
--------------------
|
|
|
|
function Messages_Count return Natural is
|
|
begin
|
|
return Count;
|
|
end Messages_Count;
|
|
|
|
end Message_Board;
|
|
|
|
------------------------
|
|
-- Number_Of_Messages --
|
|
------------------------
|
|
|
|
function Number_Of_Messages return Natural is
|
|
begin
|
|
return Message_Board.Messages_Count;
|
|
end Number_Of_Messages;
|
|
|
|
---------------------
|
|
-- Penpals_Handler --
|
|
---------------------
|
|
|
|
protected body Penpals_Handler is
|
|
|
|
---------
|
|
-- Add --
|
|
---------
|
|
|
|
procedure Add (Penpal : Penpal_Pointer) is
|
|
Name : constant String := Name_Of (Penpal);
|
|
Current : Penpal_List := Lookup (Name);
|
|
begin
|
|
if Current = null then
|
|
Penpals := new Penpal_Node'(Name => new String'(Name),
|
|
Penpal => Penpal,
|
|
Next_Penpal => Penpals);
|
|
Count := Count + 1;
|
|
else
|
|
Current.Penpal := Penpal;
|
|
end if;
|
|
end Add;
|
|
|
|
--------------
|
|
-- Get_List --
|
|
--------------
|
|
|
|
function Get_List return Penpal_Array is
|
|
Result : Penpal_Array (1 .. Count);
|
|
Current : Penpal_List := Penpals;
|
|
begin
|
|
for I in 1 .. Count loop
|
|
Result (I) := Current.all;
|
|
|
|
-- Since the Next_Penpal has no meaning here, clear it
|
|
Result (I) .Next_Penpal := null;
|
|
|
|
Current := Current.Next_Penpal;
|
|
end loop;
|
|
return Result;
|
|
end Get_List;
|
|
|
|
------------
|
|
-- Lookup --
|
|
------------
|
|
|
|
function Lookup (Name : String) return Penpal_Pointer is
|
|
Current : constant Penpal_List := Lookup (Name);
|
|
begin
|
|
if Current = null then
|
|
raise No_Such_Penpal;
|
|
else
|
|
return Current.Penpal;
|
|
end if;
|
|
end Lookup;
|
|
|
|
------------
|
|
-- Lookup --
|
|
------------
|
|
|
|
function Lookup (Name : String) return Penpal_List is
|
|
Current : Penpal_List := Penpals;
|
|
Low_Name : constant String := To_Lower (Name);
|
|
begin
|
|
while Current /= null loop
|
|
begin
|
|
if To_Lower (Current.Name.all) = Low_Name then
|
|
return Current;
|
|
end if;
|
|
exception
|
|
when System.RPC.Communication_Error =>
|
|
-- The given name is unreachable, don't give it, return
|
|
-- null instead.
|
|
|
|
return null;
|
|
end;
|
|
Current := Current.Next_Penpal;
|
|
end loop;
|
|
return null;
|
|
end Lookup;
|
|
|
|
end Penpals_Handler;
|
|
|
|
------------------
|
|
-- Post_Message --
|
|
------------------
|
|
|
|
procedure Post_Message
|
|
(Sender : String;
|
|
Message : String)
|
|
is
|
|
begin
|
|
-- Add the message to the message board
|
|
|
|
Put_Line ("Posting a message from <" & Sender & ">: """ &
|
|
Message & """");
|
|
Message_Board.Add_Message (Sender, Message);
|
|
|
|
-- For each registered client, send it the message
|
|
|
|
Broadcast (Sender, Message);
|
|
end Post_Message;
|
|
|
|
--------------
|
|
-- Register --
|
|
--------------
|
|
|
|
procedure Register (Penpal : Penpal_Pointer) is
|
|
begin
|
|
Put_Line ("Registering a new penpal <" & Name_Of (Penpal) & ">");
|
|
Penpals_Handler.Add (Penpal);
|
|
end Register;
|
|
|
|
end Server;
|