ada/PolyORB
0
0
Fork 0
mirror of https://github.com/AdaCore/PolyORB.git synced 2026-02-12 13:01:15 -08:00
Code Issues Packages Projects Releases Wiki Activity
Files
2.12
PolyORB/src/polyorb-orb.adb
Thomas Quinot b11d35d881 More accessibility fixes after change for MC03-013 
Subversion-branch: /trunk/polyorb
Subversion-revision: 226475
2014-04-18 14:48:07 +00:00

1499 lines
47 KiB
Ada
Raw Permalink Blame History

------------------------------------------------------------------------------
-- --
-- POLYORB COMPONENTS --
-- --
-- P O L Y O R B . O R B --
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2014, 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. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- PolyORB is maintained by AdaCore --
-- (email: sales@adacore.com) --
-- --
------------------------------------------------------------------------------
pragma Ada_2005;
-- The ORB core module
with Ada.Exceptions;
with Ada.Finalization;
with Ada.Tags;
with PolyORB.Any.Initialization;
with PolyORB.Binding_Data.Local;
with PolyORB.Binding_Object_QoS;
with PolyORB.Errors;
with PolyORB.Filters.Iface;
with PolyORB.Initialization;
with PolyORB.Log;
with PolyORB.ORB.Iface;
with PolyORB.Parameters.Initialization;
with PolyORB.References.Binding;
with PolyORB.Request_QoS;
with PolyORB.Servants.Iface;
with PolyORB.Setup;
with PolyORB.Smart_Pointers.Initialization;
with PolyORB.Tasking.Mutexes;
with PolyORB.Tasking.Threads;
with PolyORB.Transport.Handlers;
with PolyORB.Utils.Strings;
-- Units included in closure for module registration purposes only
pragma Warnings (Off, PolyORB.Any.Initialization);
pragma Warnings (Off, PolyORB.Parameters.Initialization);
pragma Warnings (Off, PolyORB.Smart_Pointers.Initialization);
package body PolyORB.ORB is
use PolyORB.Annotations;
use PolyORB.Asynch_Ev;
use PolyORB.Binding_Data;
use PolyORB.Binding_Objects;
use PolyORB.Components;
use PolyORB.Filters;
use PolyORB.Jobs;
use PolyORB.Log;
use PolyORB.ORB_Controller;
use PolyORB.References;
use PolyORB.Requests;
use PolyORB.Tasking.Mutexes;
use PolyORB.Tasking.Threads;
use PolyORB.Transport;
use PolyORB.Transport.Handlers;
use Unsigned_Long_Flags;
package L is new PolyORB.Log.Facility_Log ("polyorb.orb");
procedure O (Message : String; Level : Log_Level := Debug)
renames L.Output;
function C (Level : Log_Level := Debug) return Boolean
renames L.Enabled;
----------------------------------------------
-- Management of asynchronous event sources --
----------------------------------------------
procedure Insert_Source
(ORB : access ORB_Type;
AES : PolyORB.Asynch_Ev.Asynch_Ev_Source_Access);
-- Insert AES in the set of asynchronous event sources monitored by ORB.
-- The caller must not hold the ORB lock.
procedure Delete_Source
(ORB : access ORB_Type;
AES : in out Asynch_Ev_Source_Access);
-- Delete AES from the set of asynchronous event sources monitored by ORB.
-- AES is destroyed. The caller must not hold the ORB lock.
--------------------------------------------
-- Annotations used by the ORB internally --
--------------------------------------------
-- Transport access point note
type TAP_Note is new Note with record
Profile_Factory : Binding_Data.Profile_Factory_Access;
AES : Asynch_Ev.Asynch_Ev_Source_Access;
end record;
-- Transport endpoint note
type TE_Note is new Note with record
AES : Asynch_Ev.Asynch_Ev_Source_Access;
end record;
---------------------------
-- ORB object operations --
---------------------------
procedure Perform_Work
(ORB : access ORB_Type;
This_Task : in out PTI.Task_Info);
pragma Inline (Perform_Work);
-- Perform one item of work assigned to This_Task
-- Precondition: Must be called from within ORB critical section.
-- Postcondition: On exit, ORB critical section has been reasserted.
-- Note: tasks running this function may exit ORB critical section
-- temporarily.
procedure Add_Binding_Object
(ORB : access ORB_Type;
BO : Binding_Object_Access);
-- Add BO to ORB's Binding_Objects list
------------------------
-- Add_Binding_Object --
------------------------
procedure Add_Binding_Object
(ORB : access ORB_Type;
BO : Binding_Object_Access)
is
begin
pragma Abort_Defer;
Enter_ORB_Critical_Section (ORB.ORB_Controller);
PBOL.Prepend (ORB.Binding_Objects, BO);
Set_Referenced (BO, Referenced => True);
Leave_ORB_Critical_Section (ORB.ORB_Controller);
end Add_Binding_Object;
------------
-- Create --
------------
procedure Create (ORB : in out ORB_Type) is
pragma Unreferenced (ORB);
begin
-- Note: this function will be completed when implementing support for
-- multiple ORB instances, as mandated by the CORBA personality.
null;
end Create;
----------------------------------
-- Find_Reusable_Binding_Object --
----------------------------------
function Find_Reusable_Binding_Object
(ORB : access ORB_Type;
Pro : Binding_Data.Profile_Access;
QoS : PolyORB.QoS.QoS_Parameters) return Smart_Pointers.Ref
is
use PBOL;
function Is_Reusable (BO_Acc : Binding_Object_Access) return Boolean;
-- True if this BO can be reused to contact the given profile with
-- the given QoS.
-----------------
-- Is_Reusable --
-----------------
function Is_Reusable (BO_Acc : Binding_Object_Access) return Boolean is
begin
if Get_Profile (BO_Acc) /= null then
-- Until bidirectionnal BO are implemented we cannot reuse the
-- server BOs as client BOs and inversely. So for the moment,
-- server BOs have a null profile and are not handled here. This
-- check shall be removed once bidirectional BO are implemented.
return Same_Node (Pro.all, Get_Profile (BO_Acc).all)
and then
PolyORB.Binding_Object_QoS.Is_Compatible (BO_Acc, QoS);
else
return False;
end if;
end Is_Reusable;
use BO_Ref_Lists;
Reusable_BOs : BO_Ref_List;
Result : Smart_Pointers.Ref;
-- Start of processing for Find_Reusable_Binding_Object
begin
pragma Debug (C, O ("Find_Reusable_Binding_Object: enter"));
pragma Debug (C, O ("#BO registered = "
& Natural'Image (Length (ORB.Binding_Objects))));
Reusable_BOs := Get_Binding_Objects (ORB, Is_Reusable'Access);
if not Is_Empty (Reusable_BOs) then
Extract_First (Reusable_BOs, Result);
-- Get_Binding_Objects with a non-null predicate is expected to
-- return at most one object.
pragma Assert (Is_Empty (Reusable_BOs));
end if;
pragma Debug (C, O ("Find_Reusable_Binding_Object: leave"));
-- If no reusable Binding Object has been found, Result is a nil Ref
return Result;
end Find_Reusable_Binding_Object;
------------------
-- Perform_Work --
------------------
procedure Perform_Work (ORB : access ORB_Type) is
Job : Job_Access;
begin
declare
SL : PTM.Scope_Lock (ORB_Critical_Section (ORB.ORB_Controller));
pragma Unreferenced (SL);
begin
Job := Get_Pending_Job (ORB.ORB_Controller);
end;
if Job /= null then
Run (Job);
end if;
end Perform_Work;
procedure Perform_Work
(ORB : access ORB_Type;
This_Task : in out Task_Info.Task_Info)
is
use PolyORB.Task_Info;
begin
pragma Debug (C, O ("Perform_Work: enter " & Image (This_Task)));
pragma Assert (Task_Info.Job (This_Task) /= null);
PTI.Scope_Lock (This_Task).Leave;
pragma Debug (C, O ("Perform_Work: " & Image (This_Task)
& " working on job "
& Ada.Tags.External_Tag
(Task_Info.Job (This_Task)'Tag)));
Run (PTI.Job (This_Task));
PTI.Scope_Lock (This_Task).Enter;
pragma Debug (C, O ("Perform_Work: leave " & Image (This_Task)));
Notify_Event (ORB.ORB_Controller, Event'(Kind => Job_Completed));
end Perform_Work;
-----------------------
-- Try_Check_Sources --
-----------------------
procedure Try_Check_Sources
(ORB : access ORB_Type;
This_Task : in out Task_Info.Task_Info);
pragma Inline (Try_Check_Sources);
-- Check ORB AESs attached to This_Task's Selector for any incoming event.
-- Precondition: Must be called from within ORB critical section.
-- Postcondition: On exit, ORB critical section has been reasserted.
-- Note: tasks running this function may exit ORB critical section
-- temporarily.
procedure Try_Check_Sources
(ORB : access ORB_Type;
This_Task : in out Task_Info.Task_Info)
is
use PolyORB.Task_Info;
begin
-- Inside the ORB critical section
pragma Debug (C, O ("Try_Check_Sources: task "
& Image (This_Task)
& " about to Check_Sources."));
PTI.Scope_Lock (This_Task).Leave;
declare
Events : constant AES_Array :=
Check_Sources (Selector (This_Task), Task_Info.Timeout (This_Task));
-- This_Task will block on this action until an event occurs on a
-- source monitored by the selector, or Abort_Check_Sources is called
-- on it.
begin
-- Reenter critical section to update ORB state
PTI.Scope_Lock (This_Task).Enter;
pragma Debug (C, O ("Try_Check_Sources: task "
& Image (This_Task)
& " returned from Check_Sources with"
& Integer'Image (Events'Length)
& " event(s)."));
-- Queue events, if any
for J in Events'Range loop
declare
H : constant access Asynch_Ev.AES_Event_Handler'Class :=
Handler (Events (J).all);
begin
if H.Stabilize then
Notify_Event
(ORB.ORB_Controller,
Event'(Kind => Queue_Event_Job,
Event_Job => Job_Access'(H.all'Unchecked_Access),
By_Task => Id (This_Task)));
end if;
end;
end loop;
-- Notify ORB controller of completion
Notify_Event (ORB.ORB_Controller,
Event'(Kind => End_Of_Check_Sources,
On_Monitor => Selector (This_Task)));
-- Inside ORB critical section
end;
end Try_Check_Sources;
---------
-- Run --
---------
-- Controlled type Task_Witness implements the Scope Lock idiom to handle
-- exceptions and asynchronous abort while we are executing the ORB main
-- loop.
type Task_Witness
(This : access Task_Info.Task_Info;
ORB_Controller : access POC.ORB_Controller'Class;
ORB_Crit_Sect : access PTM.Mutex_Type'Class;
TI_Reference : access PTI.Task_Info_Access;
Req : access Requests.Request)
is new Ada.Finalization.Limited_Controlled with
record
Scope_Lock : aliased PTM.Scope_Lock (ORB_Crit_Sect);
-- Scope lock for the ORB critical section
Normal_Exit : Boolean := False;
-- Set True when exiting through normal completion of the protected
-- block (as opposed to abort or exception).
end record;
overriding procedure Initialize (TW : in out Task_Witness);
-- Register TW.This with OC
overriding procedure Finalize (TW : in out Task_Witness);
-- Unregister TW.This from OC
----------------
-- Initialize --
----------------
overriding procedure Initialize (TW : in out Task_Witness) is
begin
pragma Debug
(O ("Initializing task witness for " & PTI.Image (TW.This.all)));
-- Make scope lock accessable
PTI.Set_Scope_Lock (TW.This.all, TW.Scope_Lock'Unchecked_Access);
-- This pointer must be reset to null before exiting Run so as to not
-- leave a dangling reference.
if TW.TI_Reference /= null then
TW.TI_Reference.all := TW.This.all'Unchecked_Access;
end if;
Register_Task (TW.ORB_Controller, TW.This.all'Unchecked_Access);
end Initialize;
--------------
-- Finalize --
--------------
overriding procedure Finalize (TW : in out Task_Witness) is
begin
pragma Debug
(O ("Finalizing task witness for " & PTI.Image (TW.This.all)
& ", Normal_Exit = " & TW.Normal_Exit'Img));
-- Remove references to TW.This
if TW.TI_Reference /= null then
TW.TI_Reference.all := null;
end if;
if not TW.Normal_Exit then
-- Reassert critical section if needed, as we'll need to remove the
-- current task from the ORB controller.
if not TW.Scope_Lock.Is_Locked then
-- Case of aborting while the critical section has been exited
-- temporarily.
TW.Scope_Lock.Enter;
end if;
if TW.Req /= null and then TW.Req.Surrogate /= null then
-- Notify surrogate that request was aborted
Emit_No_Reply
(TW.Req.Surrogate,
Servants.Iface.Abort_Request'
(Req => TW.Req.all'Unchecked_Access));
end if;
Terminate_Task (TW.ORB_Controller, TW.This.all'Unchecked_Access);
end if;
Unregister_Task (TW.ORB_Controller, TW.This.all'Unchecked_Access);
end Finalize;
-- An ORB task is Permanent if its Request is null (case True), Transient
-- if it is not.
-- This is the main loop for all general-purpose ORB tasks. This subprogram
-- must not be called recursively. Exceptions must not be propagated from
-- within ORB critical section.
procedure Run
(ORB : access ORB_Type;
Request : Requests.Request_Access := null;
May_Exit : Boolean)
is
use PTI;
Task_Kinds : constant array (Boolean) of Task_Kind :=
(False => Transient, True => Permanent);
This_Task : aliased PTI.Task_Info (Task_Kinds (Request = null));
TI_Ref : access Task_Info_Access := null;
begin
pragma Assert (This_Task.Kind = Permanent or else May_Exit);
-- May_Exit is expected to always be True for transient tasks
-- Set up task information for This_Task
Set_Id (This_Task);
if Request /= null then
Set_Exit_Condition (This_Task, Request.Completed'Access);
TI_Ref := Request.Requesting_Task'Access;
else
Set_Exit_Condition (This_Task, null);
end if;
Set_May_Exit (This_Task, May_Exit);
-- Enter critical section (Witness establishes a Scope_Lock)
declare
Witness : Task_Witness
(This => This_Task'Unchecked_Access,
ORB_Controller => ORB.ORB_Controller,
ORB_Crit_Sect =>
ORB_Critical_Section (ORB.ORB_Controller),
TI_Reference => TI_Ref,
Req => Request);
begin
-- ORB Main loop
Main_Loop :
loop
Schedule_Task
(ORB.ORB_Controller,
This_Task'Unchecked_Access,
Witness.Scope_Lock'Unchecked_Access);
case State (This_Task) is
when Running =>
-- This task will process one job
Perform_Work (ORB, This_Task);
when Blocked =>
-- This task will block on event sources, waiting for events
Try_Check_Sources (ORB, This_Task);
when Idle =>
-- This task is going idle. We are still inside the ORB
-- critical section at this point. The tasking policy will
-- release it while we are idle, and re-assert it before
-- returning.
Idle
(ORB.Tasking_Policy,
This_Task'Unchecked_Access,
ORB_Access (ORB));
-- Note: tasking policy may have decided to terminate this
-- task, in which case the ORB controller has already been
-- notified.
if State (This_Task) /= Terminated then
Notify_Event
(ORB.ORB_Controller,
Event'(Kind => Idle_Awake,
Awakened_Task => This_Task'Unchecked_Access));
end if;
when Terminated =>
-- This task has reached its exit condition: leave main loop
exit Main_Loop;
when Unscheduled =>
-- This task is still unscheduled, this should not happen!
raise Program_Error;
end case;
-- Condition at end of loop: inside the ORB critical section
end loop Main_Loop;
Witness.Normal_Exit := True;
-- Upon exiting this block, Witness is finalized, causing This_Task
-- to be unregistered from the ORB controller.
end;
pragma Debug (C, O ("Run: leave."));
exception
when E : others =>
O ("ORB.Run got exception:", Error);
O (Ada.Exceptions.Exception_Information (E), Error);
raise;
end Run;
------------------
-- Work_Pending --
------------------
function Work_Pending (ORB : access ORB_Type) return Boolean is
SL : Scope_Lock (ORB_Critical_Section (ORB.ORB_Controller));
pragma Unreferenced (SL);
begin
return Has_Pending_Job (ORB.ORB_Controller);
end Work_Pending;
--------------
-- Shutdown --
--------------
procedure Shutdown
(ORB : access ORB_Type;
Wait_For_Completion : Boolean := True)
is
SL : PTM.Scope_Lock (ORB_Critical_Section (ORB.ORB_Controller));
pragma Unreferenced (SL);
begin
pragma Debug (C, O ("Shutdown: enter"));
-- Stop accepting incoming connections
-- XXX TBD
-- Shutdown the ORB
Notify_Event (ORB.ORB_Controller, Event'(Kind => ORB_Shutdown));
-- Wait for completion of pending requests, if required
if Wait_For_Completion then
ORB_Controller.Wait_For_Completion (ORB.ORB_Controller);
end if;
pragma Debug (C, O ("Shutdown: leave"));
end Shutdown;
------------------------
-- Profile_Factory_Of --
------------------------
function Profile_Factory_Of
(TAP : Transport.Transport_Access_Point_Access)
return Binding_Data.Profile_Factory_Access;
pragma Inline (Profile_Factory_Of);
function Profile_Factory_Of
(TAP : Transport.Transport_Access_Point_Access)
return Binding_Data.Profile_Factory_Access
is
N : TAP_Note;
begin
Get_Note (Notepad_Of (TAP).all, N);
return N.Profile_Factory;
end Profile_Factory_Of;
---------------------------
-- Register_Access_Point --
---------------------------
procedure Register_Access_Point
(ORB : access ORB_Type;
TAP : PT.Transport_Access_Point_Access;
Chain : PF.Factories_Access;
PF : PBD.Profile_Factory_Access)
is
New_AES : constant Asynch_Ev_Source_Access := Create_Event_Source (TAP);
begin
pragma Abort_Defer;
pragma Debug (C, O ("Register_Access_Point: enter"));
-- Set link from AES to TAP, Chain and PF
declare
H : constant access AES_Event_Handler'Class :=
Handler (New_AES.all);
TAP_H : TAP_AES_Event_Handler renames TAP_AES_Event_Handler (H.all);
begin
H.AES := New_AES;
TAP_H.ORB := ORB_Access (ORB);
TAP_H.TAP := TAP;
TAP_H.Filter_Factory_Chain := Chain;
TAP_H.Profile_Factory := PF;
end;
-- Set link from TAP to PF, and from TAP to AES
Set_Note (Notepad_Of (TAP).all,
TAP_Note'(Note with Profile_Factory => PF, AES => New_AES));
Enter_ORB_Critical_Section (ORB.ORB_Controller);
pragma Debug (C, O ("Inserting new source: Access Point"));
TAP_Lists.Append (ORB.Transport_Access_Points, TAP);
Leave_ORB_Critical_Section (ORB.ORB_Controller);
Insert_Source (ORB, New_AES);
pragma Debug (C, O ("Register_Access_Point: leave"));
end Register_Access_Point;
----------------------
-- Is_Profile_Local --
----------------------
function Is_Profile_Local
(ORB : access ORB_Type;
P : access Binding_Data.Profile_Type'Class) return Boolean
is
begin
if Binding_Data.Is_Local_Profile (P.all) then
return True;
end if;
declare
use TAP_Lists;
SL : PTM.Scope_Lock (ORB_Critical_Section (ORB.ORB_Controller));
pragma Unreferenced (SL);
It : Iterator := First (ORB.Transport_Access_Points);
PF : Profile_Factory_Access;
begin
while not Last (It) loop
PF := Profile_Factory_Of (Value (It).all);
if PF /= null and then Binding_Data.Is_Local_Profile (PF, P) then
return True;
end if;
Next (It);
end loop;
return False;
end;
end Is_Profile_Local;
-----------------------------
-- Register_Binding_Object --
-----------------------------
procedure Register_Binding_Object
(ORB : access ORB_Type;
BO : Smart_Pointers.Ref;
Role : Endpoint_Role)
is
TE : constant Transport.Transport_Endpoint_Access :=
Binding_Objects.Get_Endpoint (BO);
New_AES : constant Asynch_Ev_Source_Access :=
Create_Event_Source (TE);
-- New_AES is null for output-only endpoints
ORB_Acc : constant ORB_Access := ORB_Access (ORB);
BO_Acc : constant Binding_Object_Access :=
Binding_Object_Access (Smart_Pointers.Entity_Of (BO));
begin
pragma Debug
(C, O ("Register_Binding_Object (" & Role'Img & "): enter"));
-- Set ORB access in all protocol stack components
Emit_No_Reply
(Component_Access (TE),
Filters.Iface.Set_Server'
(Server => Component_Access (ORB),
Binding_Object => BO_Acc));
if New_AES /= null then
-- This is not a write only Endpoint
declare
H : constant access AES_Event_Handler'Class :=
Handler (New_AES.all);
TE_H : TE_AES_Event_Handler renames TE_AES_Event_Handler (H.all);
begin
-- Register link from AES to TE
H.AES := New_AES;
TE_H.ORB := ORB_Access (ORB);
TE_H.TE := TE;
end;
end if;
-- Register link from TE to AES
Set_Note
(Notepad_Of (TE).all, TE_Note'(Annotations.Note with AES => New_AES));
-- Assign execution resources to the newly-created connection
case Role is
when Server =>
Handle_New_Server_Connection
(ORB_Acc.Tasking_Policy,
ORB_Acc,
Active_Connection'(AES => New_AES, TE => TE));
when Client =>
Handle_New_Client_Connection
(ORB_Acc.Tasking_Policy,
ORB_Acc,
Active_Connection'(AES => New_AES, TE => TE));
end case;
-- Finally register BO in the Binding_Objects list of ORB. From this
-- point on, the BO must be fully initialized, as another task may
-- retrieve it through Find_Reusable_Binding_Object.
Add_Binding_Object (ORB, BO_Acc);
pragma Debug (C, O ("Register_Binding_Object: leave"));
end Register_Binding_Object;
-------------------------------
-- Unregister_Binding_Object --
-------------------------------
procedure Unregister_Binding_Object
(ORB : access ORB_Type;
BO : Binding_Object_Access)
is
ORB_Acc : constant ORB_Access := ORB_Access (ORB);
begin
pragma Abort_Defer;
pragma Debug (C, O ("Unregister_Binding_Object: enter"));
Enter_ORB_Critical_Section (ORB_Acc.ORB_Controller);
-- If BO is still referenced, remove it now
if Referenced (BO) then
pragma Debug (C, O ("removing binding object"));
Set_Referenced (BO, Referenced => False);
PBOL.Remove_Element (ORB_Acc.Binding_Objects, BO);
end if;
Leave_ORB_Critical_Section (ORB_Acc.ORB_Controller);
pragma Debug (C, O ("Unregister_Binding_Object: leave"));
end Unregister_Binding_Object;
------------------------
-- Set_Object_Adapter --
------------------------
procedure Set_Object_Adapter
(ORB : access ORB_Type;
OA : Obj_Adapters.Obj_Adapter_Access)
is
use type Obj_Adapters.Obj_Adapter_Access;
begin
pragma Abort_Defer;
Enter_ORB_Critical_Section (ORB.ORB_Controller);
pragma Assert (ORB.Obj_Adapter = null);
ORB.Obj_Adapter := OA;
Leave_ORB_Critical_Section (ORB.ORB_Controller);
end Set_Object_Adapter;
--------------------
-- Object_Adapter --
--------------------
function Object_Adapter (ORB : access ORB_Type)
return Obj_Adapters.Obj_Adapter_Access is
begin
-- Per construction, ORB.Obj_Adapter is a read-only component.
-- No critical section is required.
return ORB.Obj_Adapter;
end Object_Adapter;
-------------------
-- Insert_Source --
-------------------
procedure Insert_Source
(ORB : access ORB_Type;
AES : Asynch_Ev_Source_Access)
is
begin
pragma Abort_Defer;
Enter_ORB_Critical_Section (ORB.ORB_Controller);
pragma Debug (C, O ("Insert_Source: enter"));
pragma Debug
(C, O ("Source type: " & Ada.Tags.External_Tag (AES.all'Tag)));
pragma Assert (AES /= null);
declare
Monitors : constant Monitor_Array :=
Get_Monitors (ORB.ORB_Controller);
AEM : Asynch_Ev_Monitor_Access;
RSR : Register_Source_Result := Unknown_Source_Type;
begin
for J in Monitors'Range loop
-- Try to register the source to an existing monitor
AEM := Monitors (J);
Disable_Polling (ORB.ORB_Controller, AEM);
RSR := Register_Source (Monitors (J), AES);
if RSR = Unknown_Source_Type then
Enable_Polling (ORB.ORB_Controller, AEM);
else
exit;
end if;
end loop;
if RSR = Unknown_Source_Type then
-- Create a new monitor and register the source
pragma Debug (C, O ("Creating new monitor"));
AEM := AEM_Factory_Of (AES.all).all;
pragma Debug (C, O ("AEM: "
& Ada.Tags.External_Tag (AEM.all'Tag)));
Create (AEM.all);
-- In this situation, no task can be polling this monitor yet,
-- so no need to disable polling.
RSR := Register_Source (AEM, AES);
end if;
pragma Assert (RSR /= Unknown_Source_Type);
if RSR = Success then
Notify_Event (ORB.ORB_Controller,
Event'(Kind => Event_Sources_Added,
Add_In_Monitor => AEM));
else
pragma Debug (C, O ("Insert_Source: failed to register source"));
null;
end if;
Enable_Polling (ORB.ORB_Controller, AEM);
end;
pragma Debug (C, O ("Insert_Source: leave"));
Leave_ORB_Critical_Section (ORB.ORB_Controller);
end Insert_Source;
-------------------
-- Delete_Source --
-------------------
procedure Delete_Source
(ORB : access ORB_Type;
AES : in out Asynch_Ev_Source_Access)
is
Success : Boolean;
Monitor : constant Asynch_Ev_Monitor_Access := AEM_Of (AES.all);
begin
pragma Abort_Defer;
Enter_ORB_Critical_Section (ORB.ORB_Controller);
pragma Debug (C, O ("Delete_Source: enter"));
-- Disable polling to enable safe modification of AES list
Disable_Polling (ORB.ORB_Controller, Monitor);
-- Remove source
Unregister_Source (Monitor.all, AES, Success);
if Success then
Notify_Event
(ORB.ORB_Controller, Event'(Kind => Event_Sources_Deleted));
end if;
-- Modification completed, enable polling
Enable_Polling (ORB.ORB_Controller, Monitor);
Leave_ORB_Critical_Section (ORB.ORB_Controller);
-- Actually destroy AES
Destroy (AES);
pragma Debug (C, O ("Delete_Source: leave"));
end Delete_Source;
----------------------------------
-- Job type for object requests --
----------------------------------
---------
-- Run --
---------
overriding procedure Run (J : not null access Request_Job) is
AJ : Job_Access := Job_Access (J);
begin
Run_Request (J.ORB, J.Request);
Free (AJ);
exception
when E : others =>
pragma Debug (C, O ("Run: Got exception "
& Ada.Exceptions.Exception_Information (E)));
Free (AJ);
raise;
end Run;
-----------------
-- Run_Request --
-----------------
procedure Run_Request (ORB : access ORB_Type; Req : Request_Access) is
begin
pragma Debug (C, O ("Run Request_Job: enter"));
pragma Assert (Req /= null);
declare
use type Task_Info.Task_Info_Access;
begin
pragma Debug (C, O ("Task " & Image (Current_Task)
& " executing: "
& Requests.Image (Req.all)));
if Req.Requesting_Task /= null then
pragma Debug
(C, O ("... requested by "
& PTI.Image (Req.Requesting_Task.all)));
null;
end if;
if Req.Completed then
-- The request can be already marked as completed in the case
-- where an error has been detected during immediate argument
-- unmarshalling (case of a malformed SOAP argument
-- representation, for example).
pragma Debug (C, O ("Request completed due to early error"));
Emit_No_Reply (Req.Requesting_Component,
Servants.Iface.Executed_Request'(Req => Req));
return;
elsif Is_Set (Sync_None, Req.Req_Flags) then
-- At this point, the request has been queued, the Sync_None
-- synchronisation policy has been completed.
-- We bounce back the response to the requesting task.
pragma Debug (C, O ("Sync_None completed"));
Emit_No_Reply (Req.Requesting_Component,
Servants.Iface.Executed_Request'(Req => Req));
Req.Completed := True;
-- At this point Req might have been destroyed, this would make
-- any further access to it erroneous???
end if;
-- Bind target reference to a servant if this is a local reference,
-- or a surrogate if this is remote reference.
declare
use PolyORB.Errors;
Error : Error_Container;
begin
References.Binding.Bind
(Req.Target,
ORB_Access (ORB),
Request_QoS.Get_Request_QoS (Req.all),
Req.Surrogate,
Req.Profile,
Local_Only => False,
Error => Error);
-- Potential race condition, we may protect this call, TBD???
if Found (Error) then
pragma Debug (C, O ("Run_Request: Got an error when binding: "
& Error_Id'Image (Error.Kind)));
-- Any error except ForwardLocation_E caught at this level
-- implies a problem within the object adapter. We bounce the
-- exception to the user for further processing.
Set_Exception (Req.all, Error);
Catch (Error);
Emit_No_Reply (Req.Requesting_Component,
Servants.Iface.Executed_Request'(Req => Req));
return;
end if;
end;
-- At this point, the server has been contacted, a binding has been
-- created, a servant manager has been reached. We are about to send
-- the request to the target.
if Is_Set (Sync_With_Server, Req.Req_Flags)
and then Is_Profile_Local (ORB, Req.Profile)
then
-- We are on the server side, and use Sync_With_Server sync scope:
-- we can send an Executed_Request message to the client prior to
-- running the request.
pragma Debug (C, O ("With_Server completed, sending"
& " Acknowledge_Request message"));
Emit_No_Reply (Req.Requesting_Component,
Servants.Iface.Acknowledge_Request'(Req => Req));
end if;
-- Setup_Environment (Oid);
-- XXX for 'Current' (applicative personality API for access
-- to the oid of the current called instance, in the context
-- of a servant handling multiple oids.)
declare
Result : constant Components.Message'Class :=
Emit (Req.Surrogate,
Servants.Iface.Execute_Request'
(Req => Req, Pro => Req.Profile));
begin
-- Unsetup_Environment ();
-- Unbind (J.Req.Target, J.ORB, Servant);
-- XXX Unbind must Release_Servant.
-- XXX Actually cannot unbind here: if the binding object is
-- destroyed that early, we won't have the opportunity to
-- receive a reply...
pragma Debug (C, O ("Run_Request: got "
& Ada.Tags.External_Tag (Result'Tag)));
if Result in Null_Message then
pragma Debug (C, O ("Run_Request: task " & Image (Current_Task)
& " queued request for later processing"));
null;
else
pragma Debug (C, O ("Run_Request: task " & Image (Current_Task)
& " processed request"));
Emit_No_Reply (Req.Requesting_Component, Result);
-- Note: On the server side, the transport layer might detect
-- a disconnect while we are processing a request. However,
-- the request contains a reference to the session (as part
-- of its Dependent_Binding_Object), so here we know that
-- the Requesting_Component is still valid (has not been
-- destroyed yet). We used to have an exception handler here
-- because requestes formely lacked this reference to the
-- binding object.
end if;
end;
end;
end Run_Request;
----------------------
-- Create_Reference --
----------------------
procedure Create_Reference
(ORB : access ORB_Type;
Oid : access Objects.Object_Id;
Typ : String;
Ref : out References.Ref)
is
use PolyORB.Binding_Data.Local;
use TAP_Lists;
SL : PTM.Scope_Lock (ORB_Critical_Section (ORB.ORB_Controller));
pragma Unreferenced (SL);
It : Iterator := First (ORB.Transport_Access_Points);
Profiles : References.Profile_Array
(1 .. Length (ORB.Transport_Access_Points) + 1);
Last_Profile : Integer := Profiles'First - 1;
begin
pragma Debug (C, O ("Create_Reference: enter"));
while not Last (It) loop
declare
PF : constant Profile_Factory_Access :=
Profile_Factory_Of (Value (It).all);
begin
if PF /= null then
-- Null profile factories may occur for access points that
-- have an ad hoc protocol stack, but no binding data info.
declare
P : constant Profile_Access :=
Create_Profile (PF, Oid.all);
begin
if P /= null then
Last_Profile := Last_Profile + 1;
Profiles (Last_Profile) := P;
end if;
end;
end if;
end;
Next (It);
end loop;
-- Add a local profile
Last_Profile := Last_Profile + 1;
Profiles (Last_Profile) := new Local_Profile_Type;
Create_Local_Profile
(Oid.all, Local_Profile_Type (Profiles (Last_Profile).all));
References.Create_Reference
(Profiles (Profiles'First .. Last_Profile), Typ, Ref);
pragma Debug (C, O ("Create_Reference: leave"));
end Create_Reference;
--------------------
-- Handle_Message --
--------------------
overriding function Handle_Message
(ORB : not null access ORB_Type;
Msg : Components.Message'Class) return Components.Message'Class
is
use Servants.Iface;
Nothing : Components.Null_Message;
begin
pragma Debug (C, O ("Handling message of type "
& Ada.Tags.External_Tag (Msg'Tag)));
if Msg in Iface.Queue_Request then
declare
QR : Iface.Queue_Request renames Iface.Queue_Request (Msg);
Req : Requests.Request_Access renames QR.Request;
begin
pragma Debug (C, O ("Queue_Request: enter"));
if QR.Requestor = null then
-- If the request was queued directly by a client, then the
-- ORB is responsible for setting its state to Completed upon
-- reception of a reply.
Req.Requesting_Component := Component_Access (ORB);
Run_Request (ORB, Req);
else
-- Case of a request received from a remote node (requestor
-- is the Session).
Req.Requesting_Component := QR.Requestor;
declare
J : constant Job_Access :=
new Request_Job'(Job with
ORB => ORB_Access (ORB),
Request => Req);
begin
Handle_Request_Execution
(ORB.Tasking_Policy,
ORB_Access (ORB),
Request_Job (J.all)'Access);
end;
end if;
pragma Debug (C, O ("Queue_Request: leave"));
end;
elsif Msg in Executed_Request then
declare
Req : Requests.Request renames Executed_Request (Msg).Req.all;
SL : PTM.Scope_Lock (ORB_Critical_Section (ORB.ORB_Controller));
pragma Unreferenced (SL);
-- The processing of Executed_Request must be done in the ORB
-- critical section, because it must not take place between the
-- time an ORB task checks its exit condition and the moment the
-- task goes idle.
use PolyORB.Task_Info;
begin
Req.Completed := True;
pragma Debug (C, O ("Request completed."));
if Req.Requesting_Task /= null then
-- Notify the requesting task
pragma Debug
(C, O ("... requesting task is "
& Task_State'Image (State (Req.Requesting_Task.all))));
Notify_Event (ORB.ORB_Controller,
Event'(Kind => Request_Result_Ready,
Requesting_Task => Req.Requesting_Task));
else
-- The requesting task has already taken note of the completion
-- of the request: nothing to do.
null;
end if;
end;
elsif Msg in Iface.Monitor_Endpoint then
declare
TE : constant Transport_Endpoint_Access :=
Iface.Monitor_Endpoint (Msg).TE;
Note : TE_Note;
begin
Get_Note (Notepad_Of (TE).all, Note);
-- Notes.AES is null for write only Endpoints; we only monitor
-- read only and read/write Endpoints.
if Note.AES /= null then
pragma Debug (C, O ("Inserting source: Monitor_Endpoint"));
Insert_Source (ORB, Note.AES);
end if;
end;
elsif Msg in Iface.Validate_Endpoint then
ORB.Tasking_Policy.Handle_Validate_TE
(Iface.Validate_Endpoint (Msg).TE);
elsif Msg in Iface.Monitor_Access_Point then
declare
TAP : constant Transport_Access_Point_Access :=
Iface.Monitor_Access_Point (Msg).TAP;
Note : TAP_Note;
begin
Get_Note (Notepad_Of (TAP).all, Note);
pragma Debug (C, O ("Inserting source: Monitor_Access_Point"));
Insert_Source (ORB, Note.AES);
end;
elsif Msg in Iface.Unregister_Endpoint then
declare
Note : TE_Note;
begin
Get_Note
(Notepad_Of (Iface.Unregister_Endpoint (Msg).TE).all, Note);
if Note.AES /= null then
Delete_Source (ORB, Note.AES);
end if;
end;
else
pragma Debug
(C, O ("ORB received unhandled message of type "
& Ada.Tags.External_Tag (Msg'Tag)));
raise Program_Error;
end if;
return Nothing;
end Handle_Message;
-------------------------
-- Get_Binding_Objects --
-------------------------
function Get_Binding_Objects
(ORB : access ORB_Type;
Predicate : access function
(BO_Acc : Binding_Object_Access) return Boolean
:= null) return BO_Ref_List
is
use PBOL;
use Smart_Pointers;
It : PBOL.Iterator;
Result : BO_Ref_List;
begin
pragma Abort_Defer;
Enter_ORB_Critical_Section (ORB.ORB_Controller);
It := First (ORB.Binding_Objects);
All_Binding_Objects :
while not Last (It) loop
declare
BO_Acc : Binding_Object_Access renames Value (It);
Ref : Smart_Pointers.Ref;
begin
-- Note: the call to Valid here may cause a TE to be detected as
-- invalid and unregistered from the ORB. The call to Unregister_
-- Endpoint will enter the ORB critical section again.
if not Valid (BO_Acc) then
-- Mark binding object as not referenced anymore and purge.
-- Note no "Next (It);" in this case, because Remove does that
-- automatically.
Set_Referenced (BO_Acc, Referenced => False);
Remove (ORB.Binding_Objects, It);
else
if Predicate = null or else Predicate (BO_Acc) then
Smart_Pointers.Reuse_Entity (Ref, Entity_Ptr (Value (It)));
-- If binding object is being finalized, Reuse_Entity leaves
-- Ref unset.
if not Is_Nil (Ref) then
BO_Ref_Lists.Prepend (Result, Ref);
end if;
-- If Predicate is not null, return first matching BO only
exit All_Binding_Objects when Predicate /= null;
end if;
Next (It);
end if;
end;
end loop All_Binding_Objects;
Leave_ORB_Critical_Section (ORB.ORB_Controller);
return Result;
end Get_Binding_Objects;
----------------
-- Notepad_Of --
----------------
function Notepad_Of
(ORB : access ORB_Type) return Annotations.Notepad_Access
is
begin
return ORB.Notepad'Access;
end Notepad_Of;
----------------
-- Initialize --
----------------
procedure Initialize;
procedure Initialize is
The_Controller : POC.ORB_Controller_Access;
begin
Create (The_Controller);
Setup.The_ORB := new ORB_Type (Setup.The_Tasking_Policy, The_Controller);
Create (Setup.The_ORB.all);
end Initialize;
------------------------------
-- Queue_Request_To_Handler --
------------------------------
procedure Queue_Request_To_Handler
(ORB : access ORB_Type;
Msg : Message'Class)
is
begin
pragma Assert (Msg in Iface.Queue_Request);
Emit_No_Reply (Component_Access (ORB), Msg);
end Queue_Request_To_Handler;
---------------------
-- Shutdown Module --
---------------------
procedure Shutdown_Module (Wait_For_Completion : Boolean);
procedure Shutdown_Module (Wait_For_Completion : Boolean) is
begin
Shutdown (Setup.The_ORB, Wait_For_Completion);
end Shutdown_Module;
use PolyORB.Initialization;
use PolyORB.Initialization.String_Lists;
use PolyORB.Utils.Strings;
begin
Register_Module
(Module_Info'
(Name => +"orb",
Conflicts => Empty,
Depends => +"orb.tasking_policy"
& "binding_data.soap?"
& "binding_data.srp?"
& "binding_data.iiop?"
& "orb_controller"
-- ??? should not have hard-coded dependencies
-- on specific protocols!
& "protocols.srp?"
& "protocols.giop?"
& "protocols.soap?"
& "smart_pointers"
& "tasking.threads",
Provides => Empty,
Implicit => False,
Init => Initialize'Access,
Shutdown => Shutdown_Module'Access));
end PolyORB.ORB;
Reference in New Issue View Git Blame Copy Permalink