diff options
Diffstat (limited to 'lib/orber/src/corba.erl')
| -rw-r--r-- | lib/orber/src/corba.erl | 2206 |
1 files changed, 0 insertions, 2206 deletions
diff --git a/lib/orber/src/corba.erl b/lib/orber/src/corba.erl deleted file mode 100644 index faebbc4059..0000000000 --- a/lib/orber/src/corba.erl +++ /dev/null @@ -1,2206 +0,0 @@ -%%-------------------------------------------------------------------- -%% -%% %CopyrightBegin% -%% -%% Copyright Ericsson AB 1997-2015. All Rights Reserved. -%% -%% Licensed under the Apache License, Version 2.0 (the "License"); -%% you may not use this file except in compliance with the License. -%% You may obtain a copy of the License at -%% -%% http://www.apache.org/licenses/LICENSE-2.0 -%% -%% Unless required by applicable law or agreed to in writing, software -%% distributed under the License is distributed on an "AS IS" BASIS, -%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -%% See the License for the specific language governing permissions and -%% limitations under the License. -%% -%% %CopyrightEnd% -%% -%% -%%-------------------------------------------------------------------- -%% File: corba.erl -%% -%% Description: -%% This file contains the CORBA::ORB interface plus some -%% Orber specific functions. -%%----------------------------------------------------------------- --module(corba). - --include_lib("orber/include/corba.hrl"). --include_lib("orber/src/orber_iiop.hrl"). - -%%----------------------------------------------------------------- -%% Standard interface CORBA -%%----------------------------------------------------------------- --export([orb_init/1, orb_init/2]). -%%----------------------------------------------------------------- -%% Standard interface CORBA::ORB -%%----------------------------------------------------------------- --export([%create_list/2, - %create_operation_list/2, - %% get_default_context/1, - %% 'BOA_init/2, - resolve_initial_references/1, - resolve_initial_references/2, - resolve_initial_references_local/1, - list_initial_services/0, - add_initial_service/2, - remove_initial_service/1, - resolve_initial_references_remote/2, - resolve_initial_references_remote/3, - list_initial_services_remote/1, - list_initial_services_remote/2, - object_to_string/1, object_to_string/2, - object_to_string/3, object_to_string/4, - string_to_object/1, - string_to_object/2]). - -%%----------------------------------------------------------------- -%% External exports -%%----------------------------------------------------------------- --export([create/2, - create/3, - create/4, - create_link/2, - create_link/3, - create_link/4, - create_remote/3, - create_remote/5, - create_link_remote/3, - create_link_remote/5, - create_nil_objref/0, - dispose/1, - create_subobject_key/2, - get_subobject_key/1, - get_pid/1, - raise/1, raise_with_state/2, - print_object/1, - print_object/2, - add_alternate_iiop_address/3, - add_FTGroup_component/4, - add_FTPrimary_component/1, - call_internal/10]). - -%%----------------------------------------------------------------- -%% Internal (inside orber implementation) exports -%%----------------------------------------------------------------- --export([call/4, call/5, reply/2, - cast/4, cast/5, locate/1, locate/2, locate/3, - request_from_iiop/6, - common_create/5, - mk_objkey/4, - mk_light_objkey/2, - objkey_to_string/1, - string_to_objkey/1, - string_to_objkey_local/1, - call_relay/3, - cast_relay/2, - handle_init/2, - handle_terminate/3, - handle_info/3, - handle_code_change/4, - handle_call/7, - handle_call/10, - handle_cast/9, - handle_cast/6, - get_implicit_context/1]). - -%%----------------------------------------------------------------- -%% Internal definitions -%%----------------------------------------------------------------- --define(DEBUG_LEVEL, 5). - --record(is, {flags = 0}). - -%% Defines possible configuration parameters a user can add when -%% creating new CORBA objects. --record(options, {sup_child = false, - persistent = false, - regname = [], - pseudo = false, - object_flags = ?ORB_INIT_FLAGS, - object_flags_set = ?ORB_INIT_FLAGS, - create_options = [], - passive = false, - group_id = 0, - internal_state}). - --record(extra, {timeout = infinity, - context = []}). - - -%%-------------------------------------------------------------------- -%% FT stuff -%%-------------------------------------------------------------------- --define(IDL_MODULES, [oe_TimeBase, - oe_CosEventComm, - oe_CosEventChannelAdmin, - oe_CosNotification, - oe_CosNotifyComm, - oe_CosNotifyFilter, - oe_GIOP]). - --define(groupid_to_table(Integer), - list_to_atom("ft_" ++ integer_to_list(Integer))). - --define(RM_TABLE_SPEC, - [{attributes, record_info(fields, ft_replication_manager)}]). --define(RO_TABLE_SPEC, - [{attributes, record_info(fields, ft_replicated_object)}]). --define(RR_TABLE_SPEC, - [{attributes, record_info(fields, ft_reply_retention)}]). - -%% how long we're allowed to wait for database tables to be available. --define(TABLE_TIMEOUT, infinite). - -%-record(rm_state, {default_options, type_options, node_port_ips}). - -%-record(node_port_ip, {node, port, ip}). - --record(ft_replication_manager, {object_group_id, - type_id, - primary, - iogr, - ref_version, - options}). - --record(ft_replicated_object, {group_id, state}). --record(ft_reply_retention, {retention_id, reply}). - -%-record(ft_properties, {replications_style, -% membership_style, -% consistency_style, -% initial_number_replicas, -% minimum_number_replicas}). - -% one should change things work with stdlib:proplist and clean up the mess. -%-record(ft_criteria, {ft_properties, -% object_location, -% object_init, -% object_impl}). - -%%------------------------------------------------------------ -%% -%% Implementation of CORBA CORBA::ORB interfaces -%% -%%------------------------------------------------------------ - -%%create_list(Count) -> -%% corba_nvlist:create_list(Count). - -%%create_operation_list(OpDef) -> -%% corba_nvlist:create_operation_list(OpDef). - -orb_init(KeyValueList) -> - orb_init(KeyValueList, "ORBER"). - -orb_init([], _Name) -> - ok; -orb_init(KeyValueList, _Name) -> - orber:multi_configure(KeyValueList). - -%%----------------------------------------------------------------- -%% Initial reference handling -%%----------------------------------------------------------------- -resolve_initial_references(ObjectId) -> - resolve_initial_references(ObjectId, []). -resolve_initial_references(ObjectId, Ctx) -> - case use_local_host(ObjectId) of - true -> - orber_initial_references:get(ObjectId); - Ref -> - string_to_object(Ref, Ctx) - end. - -resolve_initial_references_local(ObjectId) -> - orber_initial_references:get(ObjectId). - -list_initial_services() -> - Local = orber_initial_references:list(), - case orber:get_ORBInitRef() of - undefined -> - Local; - InitRef -> - orber_tb:unique(Local ++ get_prefixes(InitRef, [])) - end. - -get_prefixes([], Acc) -> - Acc; -%% A list of ORBInitRef's -get_prefixes([H|T], Acc) when is_list(H) -> - [Key|_] = string:tokens(H, "="), - get_prefixes(T, [Key|Acc]); -%% A single ORBInitRef -get_prefixes(InitRef, _Acc) when is_list(InitRef) -> - [Key|_] = string:tokens(InitRef, "="), - [Key]; -get_prefixes(What, _) -> - orber:dbg("[~p] corba:get_prefixes(~p);~nMalformed argument?", - [?LINE, What], ?DEBUG_LEVEL), - raise(#'BAD_PARAM'{completion_status = ?COMPLETED_NO}). - - -use_local_host(ObjectId) -> - case orber:get_ORBInitRef() of - undefined -> - case orber:get_ORBDefaultInitRef() of - undefined -> - true; - DefRef -> - DefRef++"/"++ObjectId - end; - InitRef -> - case check_prefixes(InitRef, ObjectId) of - false -> - case orber:get_ORBDefaultInitRef() of - undefined -> - true; - DefRef -> - DefRef++"/"++ObjectId - end; - UseRef -> - strip_junk(UseRef) - end - end. - - -check_prefixes([], _) -> - false; -%% A list of ORBInitRef's -check_prefixes([H|T], ObjectId) when is_list(H) -> - case prefix(ObjectId, H) of - false -> - check_prefixes(T, ObjectId); - UseRef -> - UseRef - end; -%% A single ORBInitRef -check_prefixes(InitRef, ObjectId) when is_list(InitRef) -> - case prefix(ObjectId, InitRef) of - false -> - false; - UseRef -> - UseRef - end; -check_prefixes(What,_) -> - orber:dbg("[~p] corba:check_prefixes(~p);~nMalformed argument?", - [?LINE, What], ?DEBUG_LEVEL), - raise(#'BAD_PARAM'{completion_status = ?COMPLETED_NO}). - - -%% Valid is, for example, "NameService = corbaloc::host/NameService". -%% Hence, we must remove ' ' and '='. -strip_junk([32|T]) -> - strip_junk(T); -strip_junk([$=|T]) -> - strip_junk(T); -strip_junk(Ref) -> - Ref. - -add_initial_service(ObjectId, ObjectRef) -> - orber_initial_references:add(ObjectId, ObjectRef). - -remove_initial_service(ObjectId) -> - orber_initial_references:remove(ObjectId). - -resolve_initial_references_remote(ObjectId, Address) -> - resolve_initial_references_remote(ObjectId, Address, []). - -resolve_initial_references_remote(_ObjectId, [], _Ctx) -> - raise(#'BAD_PARAM'{completion_status=?COMPLETED_NO}); -resolve_initial_references_remote(ObjectId, [RemoteModifier| Rest], Ctx) - when is_list(RemoteModifier) -> - case parse_remote_modifier(RemoteModifier) of - {error, _} -> - resolve_initial_references_remote(ObjectId, Rest, Ctx); - {ok, Host, Port} -> - IOR = iop_ior:create_external(orber:giop_version(), "", - Host, list_to_integer(Port), "INIT"), - %% We know it's an external referens. Hence, no need to check. - {_, Key} = iop_ior:get_key(IOR), - orber_iiop:request(Key, 'get', [ObjectId], - {{'tk_objref', 12, "object"}, - [{'tk_string', 0}], - []}, 'true', infinity, IOR, Ctx) - end. - -list_initial_services_remote(Address) -> - list_initial_services_remote(Address, []). - -list_initial_services_remote([], _Ctx) -> - raise(#'BAD_PARAM'{completion_status=?COMPLETED_NO}); -list_initial_services_remote([RemoteModifier| Rest], Ctx) when is_list(RemoteModifier) -> - case parse_remote_modifier(RemoteModifier) of - {error, _} -> - resolve_initial_references_remote(Rest, Ctx); - {ok, Host, Port} -> - IOR = iop_ior:create_external(orber:giop_version(), "", - Host, list_to_integer(Port), "INIT"), - %% We know it's an external referens. Hence, no need to check. - {_, Key} = iop_ior:get_key(IOR), - orber_iiop:request(Key, 'list', [], - {{'tk_sequence', {'tk_string',0},0}, - [], []}, 'true', infinity, IOR, Ctx) - end; -list_initial_services_remote(_, _) -> - raise(#'BAD_PARAM'{completion_status=?COMPLETED_NO}). - - -parse_remote_modifier("iiop://" ++ Rest) -> - parse_host_version(Rest); -parse_remote_modifier(_RemoteModifier) -> - {error, not_supported}. - -parse_host_version("[" ++ Rest) -> - parse_ipv6(Rest, []); -parse_host_version(Rest) -> - parse_ipv4_or_dnsname(Rest, []). - - -parse_ipv4_or_dnsname([$: |Rest], Acc) -> - {ok, lists:reverse(Acc), Rest}; -parse_ipv4_or_dnsname([C |Rest], Acc) -> - parse_ipv4_or_dnsname(Rest, [C |Acc]). - -parse_ipv6("]:" ++ Rest, Acc) -> - {ok, lists:reverse(Acc), Rest}; -parse_ipv6([C |Rest], Acc) -> - parse_ipv6(Rest, [C |Acc]). - - -%%----------------------------------------------------------------- -%% Objectreference convertions -%%----------------------------------------------------------------- -object_to_string(Object) -> - iop_ior:string_code(Object). - -object_to_string(Object, [H|_] = Hosts) when is_list(H) -> - iop_ior:string_code(Object, Hosts); -object_to_string(_Object, _Hosts) -> - raise(#'BAD_PARAM'{completion_status=?COMPLETED_NO}). - -object_to_string(Object, [H|_] = Hosts, Port) when is_list(H) andalso - is_integer(Port) -> - iop_ior:string_code(Object, Hosts, Port); -object_to_string(_Object, _Hosts, _Port) -> - raise(#'BAD_PARAM'{completion_status=?COMPLETED_NO}). - -object_to_string(Object, [H|_] = Hosts, Port, SSLPort) when is_list(H) andalso - is_integer(Port) andalso - is_integer(SSLPort)-> - iop_ior:string_code(Object, Hosts, Port, SSLPort); -object_to_string(_Object, _Hosts, _Port, _SSLPort) -> - raise(#'BAD_PARAM'{completion_status=?COMPLETED_NO}). - - -string_to_object(IORString) -> - string_to_object(IORString, []). - -string_to_object(IORString, Ctx) when is_list(Ctx) -> - case lists:prefix("IOR", IORString) of - true -> - {ObjRef, _, _} = iop_ior:string_decode(IORString), - ObjRef; - _ -> - %% CORBA-2.4 allows both IOR and ior prefix. - case lists:prefix("ior", IORString) of - true -> - {ObjRef, _, _} = iop_ior:string_decode(IORString), - ObjRef; - _ -> - Data = orber_cosnaming_utils:select_type(IORString), - case orber_cosnaming_utils:lookup(Data, Ctx) of - String when is_list(String) -> - {Obj, _, _} = iop_ior:string_decode(String), - Obj; - ObjRef -> - ObjRef - end - end - end; -string_to_object(IORString, Ctx) -> - orber:dbg("[~p] corba:string_to_object(~p, ~p);~n" - "Failed to supply a context list.", - [?LINE, IORString, Ctx], ?DEBUG_LEVEL), - raise(#'BAD_PARAM'{completion_status=?COMPLETED_NO}). - -%%------------------------------------------------------------ -%% -%% Implementation of NON-standard functions -%% -%%------------------------------------------------------------ -create(Module, TypeID) -> - create(Module, TypeID, []). - -create(Module, TypeID, Env) -> - common_create(Module, TypeID, Env, [], 'start'). - -create(Module, TypeID, Env, {Type, RegName}) -> - common_create(Module, TypeID, Env, [{regname, {Type, RegName}}], 'start'); -create(Module, TypeID, Env, Options) -> - common_create(Module, TypeID, Env, Options, 'start'). - - -create_link(Module, TypeID) -> - create_link(Module, TypeID, []). - -create_link(Module, TypeID, Env) -> - common_create(Module, TypeID, Env, [], 'start_link'). - -create_link(Module, TypeID, Env, {Type, RegName}) -> - common_create(Module, TypeID, Env, [{regname, {Type, RegName}}], 'start_link'); -create_link(Module, TypeID, Env, Options) -> - common_create(Module, TypeID, Env, Options, 'start_link'). - - -create_remote(Node, Module, TypeID) -> - create_remote(Node, Module, TypeID, []). - -create_remote(Node, Module, TypeID, Env) -> - common_create_remote(Node, Module, TypeID, Env, [], 'start'). - -create_remote(Node, Module, TypeID, Env, {Type, RegName}) -> - common_create_remote(Node, Module, TypeID, Env, [{regname, {Type, RegName}}], 'start'); -create_remote(Node, Module, TypeID, Env, Options) -> - common_create_remote(Node, Module, TypeID, Env, Options, 'start'). - - -create_link_remote(Node, Module, TypeID) -> - create_link_remote(Node, Module, TypeID, []). - -create_link_remote(Node, Module, TypeID, Env) -> - common_create_remote(Node, Module, TypeID, Env, [], 'start_link'). - -create_link_remote(Node, Module, TypeID, Env, {Type, RegName}) -> - common_create_remote(Node, Module, TypeID, Env, [{regname, {Type, RegName}}], 'start_link'); -create_link_remote(Node, Module, TypeID, Env, Options) -> - common_create_remote(Node, Module, TypeID, Env, Options, 'start_link'). - -common_create_remote(Node, Module, TypeID, Env, {Type, RegName}, StartMethod) -> - common_create_remote(Node, Module, TypeID, Env, [{regname, {Type, RegName}}], StartMethod); -common_create_remote(Node, Module, TypeID, Env, Options, StartMethod) -> - case node_check(Node) of - true -> - rpc:call(Node, corba, common_create, [Module, TypeID, Env, Options, StartMethod]); - _ -> - orber:dbg("[~p] corba:common_create_remote(~p);~n" - "Node not in current domain.", [?LINE, Node], ?DEBUG_LEVEL), - raise(#'OBJ_ADAPTER'{completion_status=?COMPLETED_NO}) - end. - -node_check(Node) -> - lists:member(Node,orber:orber_nodes()). - -common_create(Module, _TypeID, Env, Options, StartMethod) when is_list(Options) -> - Opt = evaluate_options(Options, #options{}), - case Opt#options.regname of - [] -> - ok; - {'local', Atom} when is_atom(Atom) andalso Opt#options.persistent == false -> - ok; - {'global', _} -> - ok; - Why -> - orber:dbg("[~p] corba:common_create(~p, ~p);~n" - "Bad name type or combination(~p).", - [?LINE, Module, Options, Why], ?DEBUG_LEVEL), - raise(#'BAD_PARAM'{minor=(?ORBER_VMCID bor 1), - completion_status=?COMPLETED_NO}) - end, - case Opt of - #options{pseudo = false, passive = false} -> - case gen_server:StartMethod(Module, {Opt#options.object_flags, Env}, - Opt#options.create_options) of - {ok, Pid} -> - case catch mk_objkey(Module, Pid, Opt#options.regname, - Opt#options.persistent, - Opt#options.object_flags) of - {'EXCEPTION', E} -> - %% This branch is only used if we couldn't register - %% our new objectkey due to an internal error in orber. - gen_server:call(Pid, stop), - raise(E); - {'EXIT', _} -> - %% This branch takes care of exit values - %% which aren't expected (due to bug). - gen_server:call(Pid, stop), - raise(#'BAD_PARAM'{minor=(?ORBER_VMCID bor 1), - completion_status=?COMPLETED_NO}); - Objkey when Opt#options.sup_child == true -> - {ok, Pid, Objkey}; - Objkey -> - Objkey - end; - X -> - X - end; - #options{pseudo = true, passive = false} -> - ModuleImpl = list_to_atom(lists:concat([Module, '_impl'])), - case ModuleImpl:init(Env) of - {ok, State} -> - create_subobject_key(mk_pseudo_objkey(Module, ModuleImpl, - Opt#options.object_flags), - State); - {ok, State,_} -> - create_subobject_key(mk_pseudo_objkey(Module, ModuleImpl, - Opt#options.object_flags), - State); - Reason -> - orber:dbg("[~p] corba:common_create(~p);~n" - "'init' function incorrect(~p).", - [?LINE, ModuleImpl, Reason], ?DEBUG_LEVEL), - raise(#'BAD_PARAM'{minor=(?ORBER_VMCID bor 1), - completion_status=?COMPLETED_NO}) - end; - #options{pseudo = false, passive = true} -> - ModuleImpl = list_to_atom(lists:concat([Module, '_impl'])), - create_subobject_key(mk_passive_objkey(Module, ModuleImpl, - Opt#options.object_flags), - ?groupid_to_table(Opt#options.group_id)); - What -> - orber:dbg("[~p] corba:common_create(~p, ~p);~n" - "not a boolean(~p).", - [?LINE, Module, Options, What], ?DEBUG_LEVEL), - raise(#'BAD_PARAM'{minor=(?ORBER_VMCID bor 1), - completion_status=?COMPLETED_NO}) - end. - -%%---------------------------------------------------------------------- -%% Function : dispose -%% Arguments : Object -%% Returns : -%% Description: Terminate the object represented by the supplied reference. -%%---------------------------------------------------------------------- -dispose(?ORBER_NIL_OBJREF) -> - ok; -dispose(Obj) -> - corba_boa:dispose(Obj). - -%%---------------------------------------------------------------------- -%% Function : create_nil_objref -%% Arguments : - -%% Returns : A NIL object reference -%% Description: -%%---------------------------------------------------------------------- -create_nil_objref() -> - ?ORBER_NIL_OBJREF. - -%%---------------------------------------------------------------------- -%% Function : create_subobject_key -%% Arguments : A local object reference and an Erlang term(). -%% Returns : A new instance of the supplied reference with the -%% sub-object field changed to the given value. -%% Description: Initially, this field is set to 'undefined' -%%---------------------------------------------------------------------- -create_subobject_key(Objkey, B) when is_binary(B) -> - iop_ior:set_privfield(Objkey, B); -create_subobject_key(Objkey, T) -> - create_subobject_key(Objkey, term_to_binary(T)). - -%%---------------------------------------------------------------------- -%% Function : get_subobject_key -%% Arguments : A local object reference -%% Returns : Erlang term(). -%% Description: Return the value set by using create_subobject_key/2 -%%---------------------------------------------------------------------- -get_subobject_key(Objkey) -> - iop_ior:get_privfield(Objkey). - -%%---------------------------------------------------------------------- -%% Function : get_pid -%% Arguments : A local object reference -%% Returns : If the object is local and is associated with a pid, this -%% pid is returned. Otherwise, external- or pseudo-object, -%% an exception is raised. -%% Description: -%%---------------------------------------------------------------------- -get_pid(Objkey) -> - case iop_ior:get_key(Objkey) of - {'internal', Key, _, _, _} -> - orber_objectkeys:get_pid(Key); - {'internal_registered', Key, _, _, _} when is_atom(Key) -> - case whereis(Key) of - undefined -> - raise(#'OBJECT_NOT_EXIST'{completion_status=?COMPLETED_NO}); - Pid -> - Pid - end; - R -> - orber:dbg("[~p] corba:get_pid(~p);~n" - "Probably a pseudo- or external object(~p).", - [?LINE, Objkey, R], ?DEBUG_LEVEL), - raise(#'INV_OBJREF'{completion_status=?COMPLETED_NO}) - end. - -%%---------------------------------------------------------------------- -%% Function : raise -%% Arguments : Local exception representation. -%% Returns : Throws the exception. -%% Description: -%%---------------------------------------------------------------------- -%% To avoid dialyzer warnings due to the use of exit/throw. --spec raise(term()) -> no_return(). -raise(E) -> - throw({'EXCEPTION', E}). - -%%---------------------------------------------------------------------- -%% Function : raise_with_state -%% Arguments : Local exception representation. -%% Returns : Throws the exception. -%% Description: -%%---------------------------------------------------------------------- -%% To avoid dialyzer warnings due to the use of exit/throw. --spec raise_with_state(term(), term()) -> no_return(). -raise_with_state(E, State) -> - throw({reply, {'EXCEPTION', E}, State}). - -%%---------------------------------------------------------------------- -%% Function : reply -%% Arguments : To - pid -%% Reply - Erlang term(). -%% Returns : -%% Description: Used to reply to the invoker but still be able -%% to do some more work in the callback module. -%%---------------------------------------------------------------------- -reply(To, Reply) -> - gen_server:reply(To, Reply). - -%%---------------------------------------------------------------------- -%% Function : print_object -%% Arguments : An object represented as one of the following: -%% - local (tuple) -%% - IOR -%% - stringified IOR -%% - corbaloc- or corbaname-schema -%% IoDevice - the same as the io-module defines. -%% Returns : -%% Description: Prints the object's components and profiles. -%%---------------------------------------------------------------------- -print_object(Object) -> - iop_ior:print(Object). -print_object(Object, IoDevice) -> - iop_ior:print(IoDevice, Object). - -%%---------------------------------------------------------------------- -%% Function : add_alternate_iiop_address -%% Arguments : Local object (tuple or IOR). -%% IP - IP-string -%% Port - integer(). -%% Returns : A local IOR with a TAG_ALTERNATE_IIOP_ADDRESS component. -%% Description: -%%---------------------------------------------------------------------- -add_alternate_iiop_address(Obj, Host, Port) when is_list(Host) andalso is_integer(Port) -> - TC = #'IOP_TaggedComponent'{tag = ?TAG_ALTERNATE_IIOP_ADDRESS, - component_data = #'ALTERNATE_IIOP_ADDRESS'{ - 'HostID' = Host, - 'Port' = Port}}, - iop_ior:add_component(Obj, TC); -add_alternate_iiop_address(_, Host, Port) -> - orber:dbg("[~p] corba:add_alternate_iiop_address(~p, ~p);~n" - "Incorrect argument(s). Host must be IP-string and Port an integer.", - [?LINE, Host, Port], ?DEBUG_LEVEL), - raise(#'BAD_PARAM'{completion_status = ?COMPLETED_NO}). - - -%%---------------------------------------------------------------------- -%% Function : add_FTGroup_component -%% Arguments : Local object (tuple or IOR). -%% FTDomain - FT Domain. String(). -%% GroupID - Replicated object group's id. Integer(). (ulonglong) -%% GroupVer - Object group's version number. Integer(). (ulong) -%% Returns : A local IOR with one TAG_FT_GROUP component. -%% Description: -%%---------------------------------------------------------------------- -add_FTGroup_component(Obj, FTDomain, GroupID, GroupVer) - when is_list(FTDomain) andalso is_integer(GroupID) andalso is_integer(GroupVer) andalso - GroupID >= ?ULONGLONGMIN andalso GroupID =< ?ULONGLONGMAX andalso - GroupVer >= ?ULONGMIN andalso GroupVer =< ?ULONGMAX -> - TC = #'IOP_TaggedComponent'{tag = ?TAG_FT_GROUP, - component_data = #'FT_TagFTGroupTaggedComponent'{ - version = #'GIOP_Version'{major = 1, minor = 0}, - ft_domain_id = FTDomain, - object_group_id = GroupID, - object_group_ref_version = GroupVer}}, - iop_ior:add_component(Obj, TC); -add_FTGroup_component(_Obj, FTDomain, GroupID, GroupVer) -> - orber:dbg("[~p] corba:add_FTGroup_component(~p, ~p, ~p);~n" - "Incorrect argument(s).", - [?LINE, FTDomain, GroupID, GroupVer], ?DEBUG_LEVEL), - raise(#'BAD_PARAM'{completion_status = ?COMPLETED_NO}). - - -%%---------------------------------------------------------------------- -%% Function : add_FTPrimary_component -%% Arguments : Local object (tuple or IOR). -%% Returns : A local IOR with one TAG_FT_PRIMARY component. -%% Description: -%%---------------------------------------------------------------------- -add_FTPrimary_component(Obj) -> - TC = #'IOP_TaggedComponent'{ - tag=?TAG_FT_PRIMARY, - component_data=#'FT_TagFTPrimaryTaggedComponent'{primary = true}}, - iop_ior:add_component(Obj, TC). - - -%%----------------------------------------------------------------- -%% Generic functions for accessing the call-back modules (i.e. X_impl.erl). -%% These functions are invoked by the generated stubs. -%%----------------------------------------------------------------- -handle_init(M, {Flags, Env}) -> - case M:init(Env) of - {ok, State} -> - {ok, {#is{flags = Flags}, State}}; - {ok,State,Timeout} -> - {ok, {#is{flags = Flags}, State}, Timeout}; - Other -> - %% E.g. ignore | {stop, Reason} - Other - end. - - -handle_terminate(M, Reason, {_InternalState, State}) -> - catch (M:terminate(Reason, State)). - -handle_info(M, Info, {InternalState, State}) -> - case catch M:handle_info(Info, State) of - {noreply,NewState} -> - {noreply, {InternalState, NewState}}; - {noreply, NewState, Timeout} -> - {noreply, {InternalState, NewState}, Timeout}; - {stop, Reason, NewState} -> - {stop, Reason, {InternalState, NewState}}; - {'EXIT', Why} -> - handle_exit(InternalState, State, Why, true, - {M, handle_info}, [Info, State]) - end. - -handle_code_change(M, OldVsn, {InternalState, State}, Extra) -> - {ok, NewState} = M:code_change(OldVsn, State, Extra), - {ok, {InternalState, NewState}}. - - -%% This function handles call Pre- & Post-conditions. -handle_call(M, F, A, {InternalState, State}, Ctx, This, From, - PreData, PostData, Stub) -> - CArgs = call_state(A, State, This, From), - case catch invoke_precond(PreData, Stub, F, CArgs) of - {'EXIT', Why} -> - handle_exit(InternalState, State, Why, false, PreData, [Stub, F, CArgs]); - {'EXCEPTION', E} -> - {reply, {'EXCEPTION', E}, {InternalState, State}}; - ok -> - Result = handle_call2(M, F, CArgs, InternalState, State, Ctx), - case catch invoke_postcond(PostData, Stub, F, CArgs, Result) of - {'EXIT', Why} -> - handle_exit(InternalState, State, Why, false, PostData, A); - {'EXCEPTION', E} -> - {reply, {'EXCEPTION', E}, {InternalState, State}}; - ok -> - Result - end - end. - - -invoke_precond(false, _, _, _) -> - ok; -invoke_precond({CondM, CondF}, Stub, F, CArgs) -> - CondM:CondF(Stub, F, CArgs). - -%% We must remove the Internal State before invoking post-cond. -invoke_postcond(false, _, _, _, _) -> - ok; -invoke_postcond({CondM, CondF}, Stub, F, CArgs, {reply, Reply, {_, NS}}) -> - CondM:CondF(Stub, F, CArgs, {reply, Reply, NS}); -invoke_postcond({CondM, CondF}, Stub, F, CArgs, {reply, Reply, {_, NS}, Timeout}) -> - CondM:CondF(Stub, F, CArgs, {reply, Reply, NS, Timeout}); -invoke_postcond({CondM, CondF}, Stub, F, CArgs, {stop, Reason, Reply, {_, NS}}) -> - CondM:CondF(Stub, F, CArgs, {stop, Reason, Reply, NS}); -invoke_postcond({CondM, CondF}, Stub, F, CArgs, {stop, Reason, {_, NS}}) -> - CondM:CondF(Stub, F, CArgs, {stop, Reason, NS}); -invoke_postcond({CondM, CondF}, Stub, F, CArgs, {noreply,{_, NS}}) -> - CondM:CondF(Stub, F, CArgs, {noreply,NS}); -invoke_postcond({CondM, CondF}, Stub, F, CArgs, {noreply,{_, NS}, Timeout}) -> - CondM:CondF(Stub, F, CArgs, {noreply, NS, Timeout}); -invoke_postcond({CondM, CondF}, Stub, F, CArgs, Result) -> - CondM:CondF(Stub, F, CArgs, Result). - - -handle_call(M, F, A, {InternalState, State}, Ctx, This, From) -> - handle_call2(M, F, call_state(A, State, This, From), InternalState, State, Ctx). - -handle_call2(M, F, A, InternalState, State, []) -> - case catch apply(M, F, A) of - {reply, Reply, NewState} -> - {reply, add_context(Reply), {InternalState, NewState}}; - {reply, Reply, NewState, Timeout} -> - {reply, add_context(Reply), {InternalState, NewState}, Timeout}; - {stop, Reason, Reply, NewState} -> - {stop, Reason, add_context(Reply), {InternalState, NewState}}; - {stop, Reason, NewState} -> - {stop, Reason, {InternalState, NewState}}; - {noreply,NewState} -> - {noreply,{InternalState, NewState}}; - {noreply,NewState,Timeout} -> - {noreply,{InternalState, NewState},Timeout}; - {'EXIT', Reason} -> - handle_exit(InternalState, State, Reason, false, {M, F}, A); - {'EXCEPTION', E} -> - {reply, add_context({'EXCEPTION', E}), {InternalState, State}}; - {Reply, NewState} -> - {reply, add_context(Reply), {InternalState, NewState}} - end; -handle_call2(M, F, A, InternalState, State, Ctx) -> - %% Set the new Context. - put(oe_server_in_context, Ctx), - case catch apply(M, F, A) of - {reply, Reply, NewState} -> - put(oe_server_in_context, undefined), - {reply, add_context(Reply), {InternalState, NewState}}; - {reply, Reply, NewState, Timeout} -> - put(oe_server_in_context, undefined), - {reply, add_context(Reply), {InternalState, NewState}, Timeout}; - {stop, Reason, Reply, NewState} -> - {stop, Reason, add_context(Reply), {InternalState, NewState}}; - {stop, Reason, NewState} -> - {stop, Reason, {InternalState, NewState}}; - {noreply,NewState} -> - put(oe_server_in_context, undefined), - {noreply, {InternalState, NewState}}; - {noreply, {InternalState, NewState}, Timeout} -> - put(oe_server_in_context, undefined), - {noreply, {InternalState, NewState},Timeout}; - {'EXIT', Reason} -> - handle_exit(InternalState, State, Reason, false, {M, F}, A); - {'EXCEPTION', E} -> - put(oe_server_in_context, undefined), - {reply, add_context({'EXCEPTION', E}), {InternalState, State}}; - {Reply, NewState} -> - put(oe_server_in_context, undefined), - {reply, add_context(Reply), {InternalState, NewState}} - end. - -call_state(A, State, false, false) -> - [State|A]; -call_state(A, State, false, From) -> - [From, State|A]; -call_state(A, State, This, false) -> - [This, State|A]; -call_state(A, State, This, From) -> - [This, From, State|A]. - -cast_state(A, State, false) -> - [State|A]; -cast_state(A, State, This) -> - [This, State|A]. - -add_context(Reply) -> - %% Reset oe_server_out_context - case put(oe_server_out_context, undefined) of - undefined -> - Reply; - _OutCtx -> - %% The previous value wasn't 'undefined', which means that - %% the server supplied a return context. - Reply - end. - - -%% This function handles call Pre- & Post-conditions. -handle_cast(M, F, A, {InternalState, State}, Ctx, This, PreData, PostData, Stub) -> - CArgs = cast_state(A, State, This), - case catch invoke_precond(PreData, Stub, F, CArgs) of - {'EXIT', Why} -> - handle_exit(InternalState, State, Why, true, PreData, [Stub, F, CArgs]); - {'EXCEPTION', _} -> - {noreply, {InternalState, State}}; - ok -> - Result = handle_cast2(M, F, CArgs, InternalState, State, Ctx), - case catch invoke_postcond(PostData, Stub, F, CArgs, Result) of - {'EXIT', Why} -> - handle_exit(InternalState, State, Why, true, PostData, A); - {'EXCEPTION', _} -> - {noreply, {InternalState, State}}; - ok -> - Result - end - end. - - -handle_cast(M, F, A, {InternalState, State}, Ctx, This) -> - handle_cast2(M, F, cast_state(A, State, This), InternalState, State, Ctx). - -handle_cast2(M, F, A, InternalState, State, []) -> - case catch apply(M, F, A) of - {noreply, NewState} -> - {noreply, {InternalState, NewState}}; - {noreply, NewState, Timeout} -> - {noreply, {InternalState, NewState}, Timeout}; - {stop, Reason, NewState} -> - {stop, Reason, {InternalState, NewState}}; - {'EXCEPTION', _} -> - {noreply, {InternalState, State}}; - {'EXIT', Reason} -> - handle_exit(InternalState, State, Reason, true, {M, F}, A); - NewState -> - {noreply, {InternalState, NewState}} - end; -handle_cast2(M, F, A, InternalState, State, Ctx) -> - put(oe_server_in_context, Ctx), - case catch apply(M, F, A) of - {noreply, NewState} -> - put(oe_server_in_context, undefined), - {noreply, {InternalState, NewState}}; - {noreply, NewState, Timeout} -> - put(oe_server_in_context, undefined), - {noreply, {InternalState, NewState}, Timeout}; - {stop, Reason, NewState} -> - {stop, Reason, {InternalState, NewState}}; - {'EXCEPTION', _} -> - put(oe_server_in_context, undefined), - {noreply, {InternalState, State}}; - {'EXIT', Reason} -> - handle_exit(InternalState, State, Reason, true, {M, F}, A); - NewState -> - put(oe_server_in_context, undefined), - {noreply, {InternalState, NewState}} - end. - -handle_exit(InternalState, State, {undef, [{M, F, _, _}|_]} = Reason, - OnewayOp, {M, F}, A) -> - case catch check_exports(M:module_info(exports), F) of - {'EXIT',{undef,_}} -> - %% No such module. - orber:dbg("~p.beam doesn't exist.~n" - "Check IC compile options (e.g. 'impl') and that the~n" - "beam-file is load-able.", - [M], ?DEBUG_LEVEL), - reply_after_exit(InternalState, State, Reason, OnewayOp, - #'OBJ_ADAPTER'{minor=(?ORBER_VMCID bor 1), - completion_status=?COMPLETED_MAYBE}); - "" -> - orber:dbg("~p:~p/~p doesn't exist.~n" - "Check spelling, export-attributes etc", - [M, F, length(A)], ?DEBUG_LEVEL), - reply_after_exit(InternalState, State, Reason, OnewayOp, - #'OBJ_ADAPTER'{minor=(?ORBER_VMCID bor 2), - completion_status=?COMPLETED_MAYBE}); - Exports when is_list(Exports) -> - orber:dbg("~p:~p/~p doesn't exist.~n" - "~p:~p~s do exists.~nCheck export-attributes etc", - [M, F, length(A), M, F, Exports], ?DEBUG_LEVEL), - reply_after_exit(InternalState, State, Reason, OnewayOp, - #'OBJ_ADAPTER'{minor=(?ORBER_VMCID bor 3), - completion_status=?COMPLETED_MAYBE}); - _ -> - %% Should never happen - reply_after_exit(InternalState, State, Reason, OnewayOp, - #'OBJ_ADAPTER'{minor=(?ORBER_VMCID bor 4), - completion_status=?COMPLETED_MAYBE}) - end; -handle_exit(InternalState, State, {undef, [{M2, F2, A2, _}|_]} = Reason, - OnewayOp, {M, F}, A) -> - case catch check_exports(M2:module_info(exports), F2) of - {'EXIT',{undef,_}} -> - %% No such module. - orber:dbg("~p.beam doesn't exist.~n" - "~p:~p/~p invoked an operation on the module above.~n" - "Check IC compile options and that the beam-file is load-able.", - [M2, M, F, length(A)], ?DEBUG_LEVEL), - reply_after_exit(InternalState, State, Reason, OnewayOp, - #'OBJ_ADAPTER'{minor=(?ORBER_VMCID bor 5), - completion_status=?COMPLETED_MAYBE}); - "" -> - orber:dbg("~p:~p/~p doesn't exist.~n" - "~p:~p/~p invoked the operation above~n" - "Check spelling, export-attributes etc", - [M2, F2, length(A2), M, F, length(A)], ?DEBUG_LEVEL), - reply_after_exit(InternalState, State, Reason, OnewayOp, - #'OBJ_ADAPTER'{minor=(?ORBER_VMCID bor 6), - completion_status=?COMPLETED_MAYBE}); - Exports when is_list(Exports) -> - orber:dbg("~p:~p/~p doesn't exist.~n" - "~p:~p~s do exist(s).~nCheck export-attributes etc~n" - "~p:~p/~p invoked the operation above~n", - [M2, F2, length(A2), M2, F2, Exports, M, F, length(A)], ?DEBUG_LEVEL), - reply_after_exit(InternalState, State, Reason, OnewayOp, - #'OBJ_ADAPTER'{minor=(?ORBER_VMCID bor 7), - completion_status=?COMPLETED_MAYBE}); - _ -> - %% Should never happen - reply_after_exit(InternalState, State, Reason, OnewayOp, - #'OBJ_ADAPTER'{minor=(?ORBER_VMCID bor 4), - completion_status=?COMPLETED_MAYBE}) - end; -%% Misc errors. We separate between direct and in-direct errors. Due to different -%% notation we must separate between different cases. -handle_exit(InternalState, State, {{case_clause,_}, [{M, F, _}|_]} = Reason, - OnewayOp, {M, F}, A) -> - orber:dbg("~p:~p/~p contains a 'case_clause' error.", - [M, F, length(A)], ?DEBUG_LEVEL), - reply_after_exit(InternalState, State, Reason, OnewayOp, - #'OBJ_ADAPTER'{minor=(?ORBER_VMCID bor 8), - completion_status=?COMPLETED_MAYBE}); -handle_exit(InternalState, State, {Reason, [{M, F, _}|_]}, OnewayOp, {M, F}, A) -> - orber:dbg("~p:~p/~p contains a '~p' error.", - [M, F, length(A), Reason], ?DEBUG_LEVEL), - reply_after_exit(InternalState, State, Reason, OnewayOp, - #'OBJ_ADAPTER'{minor=(?ORBER_VMCID bor 8), - completion_status=?COMPLETED_MAYBE}); -handle_exit(InternalState, State, {function_clause, [{M2, F2, A2}|_]} = Reason, - OnewayOp, {M, F}, A) -> - orber:dbg("~p:~p/~p contains a 'function_clause' error.~n" - "Invoked via the operation:~n" - "~p:~p/~p", - [M2, F2, length(A2), M, F, length(A)], ?DEBUG_LEVEL), - reply_after_exit(InternalState, State, Reason, OnewayOp, - #'OBJ_ADAPTER'{minor=(?ORBER_VMCID bor 9), - completion_status=?COMPLETED_MAYBE}); -handle_exit(InternalState, State, {{case_clause,_}, [{M2, F2, A2}|_]} = Reason, - OnewayOp, {M, F}, A) -> - orber:dbg("~p:~p/~p contains a 'case_clause' error.~n" - "Invoked via the operation:~n" - "~p:~p/~p", - [M2, F2, A2, M, F, length(A)], ?DEBUG_LEVEL), - reply_after_exit(InternalState, State, Reason, OnewayOp, - #'OBJ_ADAPTER'{minor=(?ORBER_VMCID bor 9), - completion_status=?COMPLETED_MAYBE}); -handle_exit(InternalState, State, {Reason, [{M2, F2, A2}|_]} = Reason, - OnewayOp, {M, F}, A) -> - orber:dbg("~p:~p/~p contains a '~p' error.~n" - "Invoked via the operation:~n" - "~p:~p/~p", - [M2, F2, A2, Reason, M, F, length(A)], ?DEBUG_LEVEL), - reply_after_exit(InternalState, State, Reason, OnewayOp, - #'OBJ_ADAPTER'{minor=(?ORBER_VMCID bor 9), - completion_status=?COMPLETED_MAYBE}); -handle_exit(InternalState, State, Reason, OnewayOp, {M, F}, A) -> - orber:dbg("~p:~p(~p) ->~n" - " {EXIT, ~p}~n", - [M, F, A, Reason], ?DEBUG_LEVEL), - reply_after_exit(InternalState, State, Reason, OnewayOp, - #'OBJ_ADAPTER'{minor=(?ORBER_VMCID bor 10), - completion_status=?COMPLETED_MAYBE}). - - -reply_after_exit(#is{flags = Flags} = InternalState, State, - Reason, OnewayOp, Exc) -> - case ?ORB_FLAG_TEST(Flags, ?ORB_SURVIVE_EXIT) of - false -> - exit(Reason); - true when OnewayOp == false -> - put(oe_server_in_context, undefined), - {reply, {'EXCEPTION', Exc}, {InternalState, State}}; - true -> - %% One-way operation. Cannot return exception. - put(oe_server_in_context, undefined), - {noreply, {InternalState, State}} - end. - - -check_exports(Exports, Op) -> - check_exports(Exports, Op, []). - -check_exports([], _, Acc) -> - Acc; -check_exports([{Op, Arity}|Rest], Op, Acc) -> - check_exports(Rest, Op, Acc ++ "/" ++ integer_to_list(Arity)); -check_exports([_|Rest], Op, Acc) -> - check_exports(Rest, Op, Acc). - - -%%----------------------------------------------------------------- -%% Corba:call - the function for reqests -%%----------------------------------------------------------------- -call(Obj, Func, Args, TypesOrMod) -> - call_helper(Obj, Func, Args, TypesOrMod, infinity, []). - -call(Obj, Func, Args, TypesOrMod, [{context, Ctx}]) -> - call_helper(Obj, Func, Args, TypesOrMod, infinity, Ctx); -call(Obj, Func, Args, TypesOrMod, [{timeout, Timeout}]) -> - call_helper(Obj, Func, Args, TypesOrMod, Timeout, []); -call(Obj, Func, Args, TypesOrMod, Extra) when is_list(Extra) -> - ExtraData = extract_extra_data(Extra, #extra{}), - call_helper(Obj, Func, Args, TypesOrMod, ExtraData#extra.timeout, - ExtraData#extra.context); -call(Obj, Func, Args, TypesOrMod, Timeout) -> - call_helper(Obj, Func, Args, TypesOrMod, Timeout, []). - -call_helper(Obj, Func, Args, TypesOrMod, Timeout, InCtx) -> - Ctx = get_implicit_context(InCtx), - case iop_ior:get_key(Obj) of - {'internal', Key, _, Flags, Mod} -> - Pid = orber_objectkeys:get_pid(Key), - call_internal(Pid, Obj, Func, Args, TypesOrMod, - ?ORB_FLAG_TEST(Flags, ?ORB_TYPECHECK), - ?ORB_FLAG_TEST(Flags, ?ORB_USE_PI), Mod, Timeout, Ctx); - {'internal_registered', Key, _, Flags, Mod} -> - call_internal(Key, Obj, Func, Args, TypesOrMod, - ?ORB_FLAG_TEST(Flags, ?ORB_TYPECHECK), - ?ORB_FLAG_TEST(Flags, ?ORB_USE_PI), Mod, Timeout, Ctx); - {'external', Key} when is_atom(TypesOrMod) -> - case catch TypesOrMod:oe_tc(Func) of - {'EXIT', What} -> - orber:dbg("[~p] corba:call_helper(~p);~n" - "The call-back module does not exist or" - " incorrect IC-version used.~nReason: ~p", - [?LINE, TypesOrMod, What], ?DEBUG_LEVEL), - raise(#'TRANSIENT'{minor=(?ORBER_VMCID bor 7), - completion_status=?COMPLETED_NO}); - undefined -> - raise(#'BAD_OPERATION'{minor = (?ORBER_VMCID bor 4), - completion_status=?COMPLETED_NO}); - Types -> - orber_iiop:request(Key, Func, Args, Types, 'true', Timeout, Obj, Ctx) - end; - {'external', Key} -> - orber_iiop:request(Key, Func, Args, TypesOrMod, 'true', Timeout, Obj, Ctx) - end. - -get_implicit_context([]) -> - case get(oe_server_in_context) of - undefined -> - []; - ImplCtx -> - ImplCtx - end; -get_implicit_context(Ctx) -> - case get(oe_server_in_context) of - undefined -> - Ctx; - ImplCtx -> - %% Both defined. An explicit interface context overrides - %% an implicit. - case check_for_interface_ctx(Ctx) of - false -> - ImplCtx; - true -> - remove_interface_ctx(ImplCtx, Ctx) - end - end. - -check_for_interface_ctx([]) -> - false; -check_for_interface_ctx([#'IOP_ServiceContext' - {context_id=?ORBER_GENERIC_CTX_ID, - context_data = {interface, _I}}|_]) -> - true; -check_for_interface_ctx([_|T]) -> - check_for_interface_ctx(T). - -remove_interface_ctx([], Acc) -> - Acc; -remove_interface_ctx([#'IOP_ServiceContext' - {context_id=?ORBER_GENERIC_CTX_ID, - context_data = {interface, _I}}|T], Acc) -> - remove_interface_ctx(T, Acc); -remove_interface_ctx([H|T], Acc) -> - remove_interface_ctx(T, [H|Acc]). - - -extract_extra_data([], ED) -> - ED; -extract_extra_data([{context, Ctx}|T], ED) -> - extract_extra_data(T, ED#extra{context = Ctx}); -extract_extra_data([{timeout, Timeout}|T], ED) -> - extract_extra_data(T, ED#extra{timeout = Timeout}). - -call_internal(Pid, Obj, Func, Args, Types, Check, PI, Mod, Timeout, Ctx) - when is_pid(Pid) andalso node(Pid) == node() -> - invoke_pi_request(PI, Obj, Ctx, Func, Args), - typecheck_request(Check, Args, Types, Func), - case catch gen_server:call(Pid, {Obj, Ctx, Func, Args}, Timeout) of - {'EXCEPTION', E} -> - invoke_pi_reply(PI, Obj, Ctx, Func, {'EXCEPTION', E}), - typecheck_reply(Check, {'EXCEPTION', E}, Mod, Func), - raise(E); - {'EXIT',{timeout, _}} -> - Exc = #'TIMEOUT'{completion_status=?COMPLETED_MAYBE}, - invoke_pi_reply(PI, Obj, Ctx, Func, {'EXCEPTION', Exc}), - raise(Exc); - {'EXIT',R} -> - orber:dbg("[~p] corba:call_internal(~p, ~p, ~p);~ncall exit(~p).", - [?LINE, Func, Args, Types, R], ?DEBUG_LEVEL), - Exc = #'TRANSIENT'{minor=(?ORBER_VMCID bor 4), - completion_status=?COMPLETED_NO}, - invoke_pi_reply(PI, Obj, Ctx, Func, {'EXCEPTION', Exc}), - raise(Exc); - Res -> - invoke_pi_reply(PI, Obj, Ctx, Func, Res), - typecheck_reply(Check, Res, Types, Func), - Res - end; -call_internal(Pid, Obj, Func, Args, Types, Check, PI, - _Mod, Timeout, Ctx) when is_pid(Pid) -> - typecheck_request(Check, Args, Types, Func), - case catch rpc:call(node(Pid), corba, call_relay, - [Pid, {Obj, Ctx, Func, Args}, Timeout]) of - {'EXCEPTION', E} -> - invoke_pi_reply(PI, Obj, Ctx, Func, {'EXCEPTION', E}), - typecheck_reply(Check, {'EXCEPTION', E}, Types, Func), - raise(E); - {badrpc, {'EXIT',R}} -> - orber:dbg("[~p] corba:call_internal(~p, ~p, ~p);~ncall exit(~p).", - [?LINE, Func, Args, Types, R], ?DEBUG_LEVEL), - Exc = #'TRANSIENT'{minor=(?ORBER_VMCID bor 3), - completion_status=?COMPLETED_MAYBE}, - invoke_pi_reply(PI, Obj, Ctx, Func, {'EXCEPTION', Exc}), - raise(Exc); - {badrpc,nodedown} -> - orber:dbg("[~p] corba:call_internal(~p, ~p, ~p);~nNode ~p down.", - [?LINE, Func, Args, Types, node(Pid)], ?DEBUG_LEVEL), - Exc = #'TRANSIENT'{minor=(?ORBER_VMCID bor 2), - completion_status=?COMPLETED_NO}, - invoke_pi_reply(PI, Obj, Ctx, Func, {'EXCEPTION', Exc}), - raise(Exc); - {badrpc, Reason} -> - orber:dbg("[~p] corba:call_internal(~p, ~p, ~p);~n" - "Unable to invoke operation due to: ~p", - [?LINE, Func, Args, Types, Reason], ?DEBUG_LEVEL), - Exc = #'TRANSIENT'{minor=(?ORBER_VMCID bor 5), - completion_status=?COMPLETED_MAYBE}, - invoke_pi_reply(PI, Obj, Ctx, Func, {'EXCEPTION', Exc}), - raise(Exc); - Res -> - invoke_pi_reply(PI, Obj, Ctx, Func, Res), - typecheck_reply(Check, Res, Types, Func), - Res - end; - -%% This case handles if the reference is created as a Pseudo object. -%% Just call apply/3. -call_internal({pseudo, Module}, Obj, Func, Args, Types, Check, PI, - _Mod, _Timeout, Ctx) -> - OldCtx = put(oe_server_in_context, Ctx), - invoke_pi_request(PI, Obj, Ctx, Func, Args), - typecheck_request(Check, Args, Types, Func), - State = binary_to_term(get_subobject_key(Obj)), - case catch apply(Module, Func, [Obj, State|Args]) of - {noreply, _} -> - put(oe_server_in_context, OldCtx), - ok; - {noreply, _, _} -> - put(oe_server_in_context, OldCtx), - ok; - {reply, Reply, _} -> - put(oe_server_in_context, OldCtx), - invoke_pi_reply(PI, Obj, Ctx, Func, Reply), - typecheck_reply(Check, Reply, Types, Func), - Reply; - {reply, Reply, _, _} -> - put(oe_server_in_context, OldCtx), - invoke_pi_reply(PI, Obj, Ctx, Func, Reply), - typecheck_reply(Check, Reply, Types, Func), - Reply; - {stop, _, Reply, _} -> - put(oe_server_in_context, OldCtx), - invoke_pi_reply(PI, Obj, Ctx, Func, Reply), - typecheck_reply(Check, Reply, Types, Func), - Reply; - {stop, _, _} -> - put(oe_server_in_context, OldCtx), - ok; - {'EXCEPTION', E} -> - put(oe_server_in_context, OldCtx), - invoke_pi_reply(PI, Obj, Ctx, Func, {'EXCEPTION', E}), - typecheck_reply(Check, {'EXCEPTION', E}, Types, Func), - raise(E); - {'EXIT', What} -> - put(oe_server_in_context, OldCtx), - orber:dbg("[~p] corba:call_internal(~p, ~p, ~p);~n" - "Pseudo object exit(~p).", - [?LINE, Func, Args, Types, What], ?DEBUG_LEVEL), - Exc = #'TRANSIENT'{minor=(?ORBER_VMCID bor 4), - completion_status=?COMPLETED_MAYBE}, - invoke_pi_reply(PI, Obj, Ctx, Func, {'EXCEPTION', Exc}), - raise(Exc); - Unknown -> - put(oe_server_in_context, OldCtx), - orber:dbg("[~p] corba:call_internal(~p, ~p, ~p);~n" - "Pseudo object failed due to bad return value (~p).", - [?LINE, Func, Args, Types, Unknown], ?DEBUG_LEVEL), - Exc = #'TRANSIENT'{minor=(?ORBER_VMCID bor 6), - completion_status=?COMPLETED_MAYBE}, - invoke_pi_reply(PI, Obj, Ctx, Func, {'EXCEPTION', Exc}), - raise(Exc) - end; -call_internal({passive, Module}, Obj, Func, Args, Types, Check, PI, - Mod, Timeout, Ctx) -> - invoke_pi_request(PI, Obj, Ctx, Func, Args), - typecheck_request(Check, Args, Types, Func), - GroupID = binary_to_term(get_subobject_key(Obj)), - Transaction = - fun() -> - ObjectGroup = read_object_group(GroupID), - call_primary_protected(ObjectGroup, Module, Obj, - Func, Args, GroupID, - get_FTRequestCtx(Ctx)) - end, - case mnesia:transaction(Transaction) of - {atomic, Reply} -> - %% this check should be inside transaction so that - %% failing typecheck_reply would result in transaction - %% abortion. Or not. call_internal(Registered...) does not - %% cancel the state transition even if the result isn't type compliant. - %% So, we do likewise. - typecheck_reply(Check, Reply, Mod, Func), - Reply; - {aborted, {not_primary, Primary, _}} -> - FTRequestCtx = mk_FTRequestCtx(10000000), - case rpc:call(Primary, corba, call_internal, - [{passive, Module}, Obj, Func, Args, - Types, Check, PI, Mod, Timeout, - [FTRequestCtx|Ctx]]) of - {badrpc, Reason} -> - orber:dbg("[~p] corba:call_passive(~p, ~p, ~p); ~n" - " badrpc(~p).", - [?LINE, Func, Args, Types, Reason],?DEBUG_LEVEL), - raise(#'TRANSIENT'{minor=0, - completion_status=?COMPLETED_MAYBE}); - %% one should keep trying request_duration_policy_value -time. - {'EXCEPTION', E} -> - invoke_pi_reply(PI, Obj, Ctx, Func, {'EXCEPTION', E}), - raise(E); - Reply -> - %% is this typecheck_reply neccessary? The check is made - %% on the remote node... - invoke_pi_reply(PI, Obj, Ctx, Func, Reply), - typecheck_reply(Check, Reply, Mod, Func), - Reply - %% generate RetentionID's and call Primary node with flag that tells - %% the node not to escalate rpc call's to next node if the primary - %% has changed again. - %% raise({not_primary, Primary}); - end; - {aborted, {throw, {'EXCEPTION', E}}} -> - invoke_pi_reply(PI, Obj, Ctx, Func, {'EXCEPTION', E}), - typecheck_reply(Check, {'EXCEPTION', E}, Mod, Func), - raise(E); - {aborted, {'EXIT', What}} -> - orber:dbg("[~p] corba:call_passive(~p, ~p, ~p); " ++ - "Passive object exit(~p).", - [?LINE, Func, Args, Types, What], ?DEBUG_LEVEL), - Exc = #'TRANSIENT'{minor=(?ORBER_VMCID bor 4), - completion_status=?COMPLETED_MAYBE}, - invoke_pi_reply(PI, Obj, Ctx, Func, {'EXCEPTION', Exc}), - raise(Exc); - {aborted, Unknown} -> - orber:dbg("[~p] corba:call_passive(~p, ~p, ~p); " ++ - "Passive object failed due to bad return value (~p).", - [?LINE, Func, Args, Types, Unknown], ?DEBUG_LEVEL), - Exc = #'TRANSIENT'{minor=(?ORBER_VMCID bor 6), - completion_status=?COMPLETED_MAYBE}, - invoke_pi_reply(PI, Obj, Ctx, Func, {'EXCEPTION', Exc}), - raise(Exc) - end; -call_internal(Registered, Obj, Func, Args, Types, Check, PI, - _Mod, Timeout, Ctx) when is_atom(Registered)-> - invoke_pi_request(PI, Obj, Ctx, Func, Args), - typecheck_request(Check, Args, Types, Func), - case whereis(Registered) of - undefined -> - Exc = #'OBJECT_NOT_EXIST'{completion_status=?COMPLETED_NO}, - invoke_pi_reply(PI, Obj, Ctx, Func, {'EXCEPTION', Exc}), - raise(Exc); - P -> - case catch gen_server:call(P, {Obj, Ctx, Func, Args}, Timeout) of - {'EXCEPTION', E} -> - invoke_pi_reply(PI, Obj, Ctx, Func, {'EXCEPTION', E}), - typecheck_reply(Check, {'EXCEPTION', E}, Types, Func), - raise(E); - {'EXIT',{timeout, _}} -> - Exc = #'TIMEOUT'{completion_status=?COMPLETED_MAYBE}, - invoke_pi_reply(PI, Obj, Ctx, Func, {'EXCEPTION', Exc}), - raise(Exc); - {'EXIT',R} -> - orber:dbg("[~p] corba:call_internal(~p, ~p, ~p).~n" - "call exit(~p).", - [?LINE, Func, Args, Types, R], ?DEBUG_LEVEL), - Exc = #'TRANSIENT'{minor=(?ORBER_VMCID bor 5), - completion_status=?COMPLETED_MAYBE}, - invoke_pi_reply(PI, Obj, Ctx, Func, {'EXCEPTION', Exc}), - raise(Exc); - Res -> - invoke_pi_reply(PI, Obj, Ctx, Func, Res), - typecheck_reply(Check, Res, Types, Func), - Res - end - end. - -invoke_pi_request(false, _Obj, _Ctx, _Func, _Args) -> - ok; -invoke_pi_request(_, Obj, Ctx, Func, Args) -> - case orber:get_cached_interceptors() of - {native, PIs} -> - orber_pi:out_request(PIs, Obj, Ctx, Func, "localhost", Args); - _ -> - ok - end. - -invoke_pi_reply(false, _Obj, _Ctx, _Func, _Res) -> - ok; -invoke_pi_reply(_, Obj, Ctx, Func, Res) -> - case orber:get_cached_interceptors() of - {native, PIs} -> - orber_pi:in_reply(PIs, Obj, Ctx, Func, "localhost", Res); - _ -> - ok - end. - -typecheck_request(false, _, _, _) -> - ok; -typecheck_request(true, Args, Mod, Func) when is_atom(Mod) -> - case catch Mod:oe_tc(Func) of - undefined -> - raise(#'BAD_OPERATION'{minor = (?ORBER_VMCID bor 4), - completion_status=?COMPLETED_NO}); - {'EXIT', What} -> - orber:dbg("[~p] corba:typecheck_request(~p, ~p, ~p);~n" - "The call-back module does not exist or incorrect" - "IC-version used.~nReason: ~p", - [?LINE, Mod, Func, Args, What], ?DEBUG_LEVEL), - raise(#'TRANSIENT'{minor=(?ORBER_VMCID bor 7), - completion_status=?COMPLETED_NO}); - Types -> - typecheck_request_helper(Types, Args, Mod, Func) - end; -typecheck_request(true, Args, Types, Func) -> - typecheck_request_helper(Types, Args, Types, Func). - -typecheck_request_helper(Types, Args, Mod, Func) -> - case catch cdr_encode:validate_request_body( - #giop_env{version = {1,2}, tc = Types, parameters = Args, - host = orber:host(), iiop_port = orber:iiop_port(), - iiop_ssl_port = orber:iiop_ssl_port(), - domain = orber:domain(), - partial_security = orber:partial_security(), - flags = orber:get_flags()}) of - {'EXCEPTION', E} -> - {_, TC, _} = Types, - error_logger:error_msg("========= Orber Typecheck Request =========~n" - "Invoked......: ~p:~p/~p~n" - "Typecode.....: ~p~n" - "Arguments....: ~p~n" - "Result.......: ~p~n" - "===========================================~n", - [Mod, Func, length(TC), TC, Args, {'EXCEPTION', E}]), - raise(E); - {'EXIT',R} -> - {_, TC, _} = Types, - error_logger:error_msg("========= Orber Typecheck Request =========~n" - "Invoked......: ~p:~p/~p~n" - "Typecode.....: ~p~n" - "Arguments....: ~p~n" - "Result.......: ~p~n" - "===========================================~n", - [Mod, Func, length(TC), TC, Args, {'EXIT',R}]), - raise(#'MARSHAL'{completion_status=?COMPLETED_MAYBE}); - _ -> - ok - end. - -typecheck_reply(true, Args, Mod, Func) when is_atom(Mod) -> - case catch Mod:oe_tc(Func) of - undefined -> - raise(#'BAD_OPERATION'{minor = (?ORBER_VMCID bor 4), - completion_status=?COMPLETED_NO}); - {'EXIT', What} -> - orber:dbg("[~p] corba:typecheck_reply(~p, ~p, ~p);~n" - "The call-back module does not exist or incorrect" - " IC-version used.~nReason: ~p", - [?LINE, Mod, Func, Args, What], ?DEBUG_LEVEL), - raise(#'TRANSIENT'{minor=(?ORBER_VMCID bor 7), - completion_status=?COMPLETED_NO}); - Types -> - typecheck_reply_helper(Types, Args, Mod, Func) - end; -typecheck_reply(true, Args, Types, Func) -> - typecheck_reply_helper(Types, Args, Types, Func); -typecheck_reply(_, _, _, _) -> - ok. - -typecheck_reply_helper(Types, Args, Mod, Func) -> - case catch cdr_encode:validate_reply_body( - #giop_env{version = {1,2}, tc = Types, - host = orber:host(), iiop_port = orber:iiop_port(), - iiop_ssl_port = orber:iiop_ssl_port(), - domain = orber:domain(), - partial_security = orber:partial_security(), - flags = orber:get_flags()}, Args) of - {'tk_except', ExcType, ExcTC, {'EXCEPTION', E}} -> - {_, TC, _} = Types, - error_logger:error_msg("========== Orber Typecheck Reply ==========~n" - "Invoked........: ~p:~p/~p~n" - "Exception Type.: ~p~n" - "Typecode.......: ~p~n" - "Raised.........: ~p~n" - "Result.........: ~p~n" - "===========================================~n", - [Mod, Func, length(TC), ExcType, ExcTC, Args, {'EXCEPTION', E}]), - raise(E); - {'EXCEPTION', E} -> - {RetType, TC, OutParams} = Types, - error_logger:error_msg("========== Orber Typecheck Reply ==========~n" - "Invoked......: ~p:~p/~p~n" - "Typecode.....: ~p~n" - "Reply........: ~p~n" - "Result.......: ~p~n" - "===========================================~n", - [Mod, Func, length(TC), [RetType | OutParams], Args, {'EXCEPTION', E}]), - raise(E); - {'tk_except', ExcType, ExcTC, {'EXIT',R}} -> - {_, TC, _} = Types, - error_logger:error_msg("========== Orber Typecheck Reply ==========~n" - "Invoked........: ~p:~p/~p~n" - "Exception Type.: ~p~n" - "Typecode.......: ~p~n" - "Raised.........: ~p~n" - "Result.........: ~p~n" - "===========================================~n", - [Mod, Func, length(TC), ExcType, ExcTC, Args, {'EXIT',R}]), - raise(#'MARSHAL'{completion_status=?COMPLETED_MAYBE}); - {'EXIT',R} -> - {RetType, TC, OutParams} = Types, - error_logger:error_msg("========== Orber Typecheck Reply ==========~n" - "Invoked........: ~p:~p/~p~n" - "Typecode.......: ~p~n" - "Reply..........: ~p~n" - "Result.........: ~p~n" - "===========================================~n", - [Mod, Func, length(TC), [RetType | OutParams], Args, {'EXIT',R}]), - raise(#'MARSHAL'{completion_status=?COMPLETED_MAYBE}); - _ -> - ok - end. - -call_relay(Pid, Data, Timeout) -> - case whereis(orber_objkeyserver) of - undefined -> - raise(#'TRANSIENT'{minor=(?ORBER_VMCID bor 1), completion_status=?COMPLETED_MAYBE}); - _ -> - case catch gen_server:call(Pid, Data, Timeout) of - {'EXCEPTION', E} -> - raise(E); - {'EXIT',{timeout, _}} -> - raise(#'TIMEOUT'{completion_status=?COMPLETED_MAYBE}); - {'EXIT',R} -> - orber:dbg("[~p] corba:call_internal(~p);~n" - "call exit(~p).", [?LINE, Data, R], ?DEBUG_LEVEL), - exit(R); - Res -> - Res - end - end. - -%%----------------------------------------------------------------- -%% Corba:cast - the function for ONEWAY requests -%%----------------------------------------------------------------- -cast(Obj, Func, Args, TypesOrMod) -> - cast_helper(Obj, Func, Args, TypesOrMod, []). - -cast(Obj, Func, Args, TypesOrMod, [{context, Ctx}]) -> - cast_helper(Obj, Func, Args, TypesOrMod, Ctx). - -cast_helper(Obj, Func, Args, TypesOrMod, InCtx) -> - Ctx = get_implicit_context(InCtx), - case iop_ior:get_key(Obj) of - {'internal', Key, _, Flags, Mod} -> - Pid = orber_objectkeys:get_pid(Key), - cast_internal(Pid, Obj, Func, Args, TypesOrMod, - ?ORB_FLAG_TEST(Flags, ?ORB_TYPECHECK), - ?ORB_FLAG_TEST(Flags, ?ORB_USE_PI), Mod, Ctx); - {'internal_registered', Key, _, Flags, Mod} -> - cast_internal(Key, Obj, Func, Args, TypesOrMod, - ?ORB_FLAG_TEST(Flags, ?ORB_TYPECHECK), - ?ORB_FLAG_TEST(Flags, ?ORB_USE_PI), Mod, Ctx); - {'external', Key} when is_atom(TypesOrMod) -> - case catch TypesOrMod:oe_tc(Func) of - {'EXIT', What} -> - orber:dbg("[~p] corba:cast_helper(~p);~n" - "The call-back module does not exist or incorrect" - " IC-version used.~nReason: ~p", - [?LINE, TypesOrMod, What], ?DEBUG_LEVEL), - raise(#'TRANSIENT'{minor=(?ORBER_VMCID bor 7), - completion_status=?COMPLETED_NO}); - undefined -> - raise(#'BAD_OPERATION'{minor = (?ORBER_VMCID bor 4), - completion_status=?COMPLETED_NO}); - Types -> - orber_iiop:request(Key, Func, Args, Types, 'false', infinity, - Obj, Ctx) - end; - {'external', Key} -> - orber_iiop:request(Key, Func, Args, TypesOrMod, 'false', infinity, - Obj, Ctx) - end. - -cast_internal(Pid, Obj, Func, Args, Types, Check, PI, _Mod, Ctx) - when is_pid(Pid) andalso node(Pid) == node() -> - invoke_pi_request(PI, Obj, Ctx, Func, Args), - typecheck_request(Check, Args, Types, Func), - catch gen_server:cast(Pid, {Obj, Ctx, Func, Args}), - ok; -cast_internal(Pid, Obj, Func, Args, Types, Check, PI, Mod, Ctx) when is_pid(Pid) -> - invoke_pi_request(PI, Obj, Ctx, Func, Args), - typecheck_request(Check, Args, Types, Func), - case catch rpc:call(node(Pid), corba, cast_relay, [Pid, {Obj, Ctx, Func, Args}]) of - {'EXCEPTION', E} -> - typecheck_reply(Check, {'EXCEPTION', E}, Mod, Func), - raise(E); - {badrpc, {'EXIT', _R}} -> - raise(#'TRANSIENT'{minor=(?ORBER_VMCID bor 3), - completion_status=?COMPLETED_MAYBE}); - {badrpc,nodedown} -> - orber:dbg("[~p] corba:cast_internal(~p, ~p, ~p);~nNode ~p down.", - [?LINE, Func, Args, Types, node(Pid)], ?DEBUG_LEVEL), - raise(#'TRANSIENT'{minor=(?ORBER_VMCID bor 2), - completion_status=?COMPLETED_NO}); - Other -> - orber:dbg("[~p] corba:cast_internal(~p, ~p, ~p);~n" - "Communication with node: ~p failed with reason: ~p.", - [?LINE, Func, Args, Types, node(Pid), Other], ?DEBUG_LEVEL), - raise(#'TRANSIENT'{minor=(?ORBER_VMCID bor 5), - completion_status=?COMPLETED_MAYBE}) - end; - -%% This case handles if the reference is created as a Pseudo object. -%% Just call apply/3. -cast_internal({pseudo, Module}, Obj, Func, Args, Types, Check, PI, _Mod, Ctx) -> - OldCtx = put(oe_server_in_context, Ctx), - invoke_pi_request(PI, Obj, Ctx, Func, Args), - typecheck_request(Check, Args, Types, Func), - State = binary_to_term(get_subobject_key(Obj)), - catch apply(Module, Func, [Obj, State|Args]), - put(oe_server_in_context, OldCtx), - ok; -cast_internal(Registered, Obj, Func, Args, Types, Check, PI, _Mod, Ctx) -> - invoke_pi_request(PI, Obj, Ctx, Func, Args), - typecheck_request(Check, Args, Types, Func), - case whereis(Registered) of - undefined -> - raise(#'OBJECT_NOT_EXIST'{completion_status=?COMPLETED_NO}); - P -> - gen_server:cast(P, {Obj, Ctx, Func, Args}) - end. - -cast_relay(Pid, Data) -> - case whereis(orber_objkeyserver) of - undefined -> - raise(#'TRANSIENT'{minor=(?ORBER_VMCID bor 1), - completion_status=?COMPLETED_NO}); - _ -> - gen_server:cast(Pid, Data) - end. - -%%----------------------------------------------------------------- -%% Corba:locate - this function is for the moment just used for tests -%%----------------------------------------------------------------- -locate(Obj) -> - locate(Obj, infinity, []). - -locate(Obj, Timeout) -> - locate(Obj, Timeout, []). - -locate(Obj, Timeout, Ctx) -> - case iop_ior:get_key(Obj) of - {'external', Key} -> - orber_iiop:locate(Key, Timeout, Obj, Ctx); - _ -> - orber_objectkeys:check(iop_ior:get_objkey(Obj)) - end. - -%%----------------------------------------------------------------- -%% Incomming request from iiop -%%----------------------------------------------------------------- -%% Operations which do not allow object invokation. -request_from_iiop(Obj, '_is_a', [Args], _, _, _) -> - catch corba_object:is_a(Obj, Args); -%% First the OMG specified this operation to be '_not_existent' and then -%% changed it to '_non_existent' without suggesting that both must be supported. -%% See CORBA2.3.1 page 15-34, Minor revision 2.3.1: October 1999 -request_from_iiop(Obj, '_not_existent', _, _, _, _) -> - catch corba_object:non_existent(Obj); -request_from_iiop(Obj, '_non_existent', _, _, _, _) -> - catch corba_object:non_existent(Obj); -request_from_iiop(_, '_FT_HB', _, _, _, _) -> - ok; - -%% "Ordinary" operations. -request_from_iiop({Mod, _, _, _, _, _}, oe_get_interface, - _, _, _, _ServiceCtx) when is_atom(Mod) -> - case catch Mod:oe_get_interface() of - {'EXIT', What} -> - orber:dbg("[~p] corba:request_from_iiop(~p);~n" - "The call-back module does not exist or" - " incorrect IC-version used.~nReason: ~p", - [?LINE, Mod, What], ?DEBUG_LEVEL), - {'EXCEPTION', #'TRANSIENT'{minor=(?ORBER_VMCID bor 7), - completion_status=?COMPLETED_NO}}; - undefined -> - {'EXCEPTION', #'BAD_OPERATION'{minor = (?ORBER_VMCID bor 4), - completion_status='COMPLETED_NO'}}; - Interface -> - Interface - end; -request_from_iiop({_Mod, pseudo, Module, _UserDef, _OrberDef, _Flags} = ObjRef, - Func, Args, Types, ResponseExpected, _ServiceCtx) -> - State = binary_to_term(get_subobject_key(ObjRef)), - case ResponseExpected of - true -> - case catch apply(Module, Func, [ObjRef, State|Args]) of - {noreply, _} -> - ok; - {noreply, _, _} -> - ok; - {reply, Reply, _} -> - Reply; - {reply, Reply, _, _} -> - Reply; - {stop, _, Reply, _} -> - Reply; - {stop, _, _} -> - ok; - {'EXCEPTION', E} -> - {'EXCEPTION', E}; - {'EXIT', {undef, _}} -> - orber:dbg("[~p] corba:request_from_iiop(~p, ~p, ~p);~n" - "The call-back module does not exist.", - [?LINE, Func, Args, Types], ?DEBUG_LEVEL), - {'EXCEPTION', #'TRANSIENT'{minor=(?ORBER_VMCID bor 4), - completion_status=?COMPLETED_NO}}; - {'EXIT', What} -> - orber:dbg("[~p] corba:request_from_iiop(~p, ~p, ~p);~n" - "Pseudo object exit(~p).~n" - "The call-back module probably contain an error.", - [?LINE, Func, Args, Types, What], ?DEBUG_LEVEL), - {'EXCEPTION', #'TRANSIENT'{minor=(?ORBER_VMCID bor 4), - completion_status=?COMPLETED_MAYBE}}; - Unknown -> - orber:dbg("[~p] corba:request_from_iiop(~p, ~p, ~p);~n" - "Pseudo object failed(~p);~n" - "Confirm that the return value is correct" - " (e.g. {reply, Reply, State})", - [?LINE, Func, Args, Types, Unknown], ?DEBUG_LEVEL), - {'EXCEPTION', #'TRANSIENT'{minor=(?ORBER_VMCID bor 6), - completion_status=?COMPLETED_MAYBE}} - end; - false -> - catch apply(Module, Func, [ObjRef, State|Args]), - ok; - true_oneway -> - catch apply(Module, Func, [ObjRef, State|Args]), - ok - end; -% FOR PASSIVE REPLICATION! (Response IS expected --- one way semantics doesn't -% really mix with intentions to be consistent & fault tolerant.) -request_from_iiop({_Mod, passive, Module, _UserDef, _OrberDef, _Flags} = ObjRef, - Func, Args, Types, true, Ctx) -> - GroupID = binary_to_term(get_subobject_key(ObjRef)), - FTGroupVersionCtx = get_FTGroupVersionCtx(Ctx), - Transaction = - fun() -> - ObjectGroup = read_object_group(GroupID), - check_version_context(ObjectGroup, - FTGroupVersionCtx), - call_primary_protected(ObjectGroup, - Module, - ObjRef, - Func, - Args, - GroupID, - get_FTRequestCtx(Ctx)) - end, - case mnesia:transaction(Transaction) of - {atomic, Reply} -> - Reply; - {aborted, {too_old_reference, IOGR}} -> - {oe_location_forward_perm, IOGR}; - {aborted, {not_primary, _Primary, IOGR}} -> - case FTGroupVersionCtx of - [] -> - {oe_location_forward_perm, IOGR}; - _ -> - {'EXCEPTION', #'TRANSIENT'{minor = 0, - completion_status = ?COMPLETED_NO}} - end; - {aborted, {throw, {'EXCEPTION', E}}} -> - {'EXCEPTION', E}; - {aborted, {'EXIT', What}} -> - orber:dbg("[~p] corba:call_passive(~p, ~p, ~p);~n" - "Passive object exit(~p).", - [?LINE, Func, Args, Types, What], ?DEBUG_LEVEL), - {'EXCEPTION', #'TRANSIENT'{minor = 0, - completion_status=?COMPLETED_MAYBE}}; - {aborted, Unknown} -> - orber:dbg("[~p] corba:call_passive(~p, ~p, ~p);~n" - "Passive object failed due to bad return value (~p).", - [?LINE, Func, Args, Types, Unknown], ?DEBUG_LEVEL), - {'EXCEPTION', #'TRANSIENT'{minor = 0, - completion_status=?COMPLETED_MAYBE}} - end; -request_from_iiop({_Mod, _Type, Key, _UserDef, _OrberDef, _Flags} = ObjRef, - Func, Args, Types, true, _ServiceCtx) -> - case catch gen_server:call(convert_key_to_pid(Key), - {ObjRef, [], Func, Args}, infinity) of - {'EXIT', What} -> - orber:dbg("[~p] corba:request_from_iiop(~p, ~p, ~p);~n" - "gen_server:call exit: ~p", - [?LINE, Func, Args, Types, What], ?DEBUG_LEVEL), - {'EXCEPTION', #'TRANSIENT'{minor=(?ORBER_VMCID bor 4), - completion_status=?COMPLETED_MAYBE}}; - Result -> - Result - end; -request_from_iiop({_Mod, _Type, Key, _UserDef, _OrberDef, _Flags} = ObjRef, - Func, Args, Types, _, _ServiceCtx) -> - case catch gen_server:cast(convert_key_to_pid(Key), - {ObjRef, [], Func, Args}) of - {'EXIT', What} -> - orber:dbg("[~p] corba:request_from_iiop(~p, ~p, ~p);~n" - "gen_server:cast exit: ~p", - [?LINE, Func, Args, Types, What], ?DEBUG_LEVEL), - {'EXCEPTION', #'TRANSIENT'{minor=(?ORBER_VMCID bor 4), - completion_status=?COMPLETED_MAYBE}}; - Result -> - Result - end. - -%%------------------------------------------------------------ -%% Internal stuff -%%------------------------------------------------------------ - -convert_key_to_pid(Key) when is_binary(Key) -> - orber_objectkeys:get_pid(Key); -convert_key_to_pid(Name) when is_atom(Name) -> - Name. - -mk_objkey(Mod, Pid, RegName, Persistent) -> - mk_objkey(Mod, Pid, RegName, Persistent, 0). - -mk_objkey(Mod, Pid, [], _, Flags) when is_pid(Pid) -> - Key = make_objkey(), - case orber_objectkeys:register(Key, Pid, false) of - ok -> - {Mod, 'key', Key, term_to_binary(undefined), 0, Flags}; - R -> - orber:dbg("[~p] corba:mk_objkey(~p);~n" - "unable to store key(~p).", [?LINE, Mod, R], ?DEBUG_LEVEL), - raise(#'INTERNAL'{minor=(?ORBER_VMCID bor 2), completion_status=?COMPLETED_NO}) - end; -mk_objkey(Mod, Pid, {'global', RegName}, Persitent, Flags) when is_pid(Pid) -> - Key = term_to_binary(RegName), - case orber_objectkeys:register(Key, Pid, Persitent) of - ok -> - {Mod, 'key', Key, term_to_binary(undefined), 0, Flags}; - R -> - orber:dbg("[~p] corba:mk_objkey(~p, ~p);~n" - "unable to store key(~p).", - [?LINE, Mod, RegName, R], ?DEBUG_LEVEL), - raise(#'INTERNAL'{minor=(?ORBER_VMCID bor 2), completion_status=?COMPLETED_NO}) - end; -mk_objkey(Mod, Pid, {'local', RegName}, Persistent, Flags) when is_pid(Pid) andalso is_atom(RegName) -> - register(RegName, Pid), - Key = make_objkey(), - case orber_objectkeys:register(Key, Pid, Persistent) of - ok -> - {Mod, 'registered', RegName, term_to_binary(undefined), 0, Flags}; - R -> - orber:dbg("[~p] corba:mk_objkey(~p, ~p);~n" - "unable to store key(~p).", - [?LINE, Mod, RegName, R], ?DEBUG_LEVEL), - raise(#'INTERNAL'{minor=(?ORBER_VMCID bor 2), completion_status=?COMPLETED_NO}) - end. - - -mk_light_objkey(Mod, RegName) -> - {Mod, 'registered', RegName, term_to_binary(undefined), 0, 0}. - -mk_pseudo_objkey(Mod, Module, Flags) -> - {Mod, 'pseudo', Module, term_to_binary(undefined), 0, Flags}. - -mk_passive_objkey(Mod, Module, Flags) -> - {Mod, 'passive', Module, term_to_binary(undefined), 0, Flags}. - -make_objkey() -> - term_to_binary({{erlang:system_time(), - erlang:unique_integer()}, - node()}). - -objkey_to_string({_Mod, 'registered', 'orber_init', _UserDef, _OrberDef, _Flags}) -> - "INIT"; -objkey_to_string({Mod, Type, Key, UserDef, OrberDef, Flags}) -> - orber:domain() ++ [ 7 | binary_to_list(term_to_binary({Mod, Type, Key, UserDef, OrberDef, Flags}))]; -objkey_to_string(External_object_key) -> - External_object_key. - -string_to_objkey("INIT") -> - {orber_initial_references, 'registered', 'orber_init', term_to_binary(undefined), 0, 0}; -string_to_objkey(String) -> - case prefix(orber:domain(), String) of - [7 | Rest] -> - binary_to_term(list_to_binary(Rest)); - _ -> - String - end. -%% This function may only be used when we know it's a local reference (i.e. target -%% key in a request; IOR's passed as argument or reply doesn't qualify)! -string_to_objkey_local("INIT") -> - {orber_initial_references, 'registered', 'orber_init', term_to_binary(undefined), 0, 0}; -string_to_objkey_local(String) -> - case prefix(orber:domain(), String) of - [7 | Rest] -> - binary_to_term(list_to_binary(Rest)); - _ -> - case resolve_initial_references(String) of - ?ORBER_NIL_OBJREF -> - orber:dbg("[~p] corba:string_to_objkey_local(~p);~n" - "Invalid ObjektKey.", [?LINE, String], ?DEBUG_LEVEL), - ?ORBER_NIL_OBJREF; - Object -> - {location_forward, Object} - end - end. - -prefix([], L2) -> - L2; -prefix([E |L1], [E | L2]) -> - prefix(L1, L2); -prefix(_, _) -> - false. - - -evaluate_options([], Options) -> - GlobalFlags = orber:get_flags(), - Options2 = check_flag(Options, ?ORB_TYPECHECK, - ?ORB_ENV_LOCAL_TYPECHECKING, GlobalFlags), - Options3 = check_flag(Options2, ?ORB_USE_PI, ?ORB_ENV_USE_PI, GlobalFlags), - check_flag(Options3, ?ORB_SURVIVE_EXIT, ?ORB_ENV_SURVIVE_EXIT, GlobalFlags); -%% Pseudo or not. -evaluate_options([{pseudo, false}|Rest], Options) -> - evaluate_options(Rest, Options); -evaluate_options([{pseudo, true}|Rest], #options{passive = false} = Options) -> - evaluate_options(Rest, Options#options{pseudo = true}); -%% FT stuff -evaluate_options([{passive, true}|Rest], #options{pseudo = false} = Options) -> - evaluate_options(Rest, Options#options{passive = true}); -evaluate_options([{group_id, ID}|Rest], Options) when is_integer(ID) -> - evaluate_options(Rest, Options#options{group_id = ID}); -%% Options accepted by gen_server (e.g. dbg). -evaluate_options([{create_options, COpt}|Rest], Options) when is_list(COpt) -> - evaluate_options(Rest, Options#options{create_options = COpt}); -%% When starting object as supervisor child. -evaluate_options([{sup_child, false}|Rest], Options) -> - evaluate_options(Rest, Options); -evaluate_options([{sup_child, true}|Rest], Options) -> - evaluate_options(Rest, Options#options{sup_child = true}); -%% Persistent object-key -evaluate_options([{persistent, false}|Rest], Options) -> - evaluate_options(Rest, Options); -evaluate_options([{persistent, true}|Rest], Options) -> - evaluate_options(Rest, Options#options{persistent = true}); -evaluate_options([{regname, []}|Rest], Options) -> - evaluate_options(Rest, Options); -evaluate_options([{regname, Name}|Rest], Options) -> - evaluate_options(Rest, Options#options{regname = Name}); -evaluate_options([{survive_exit, false}|Rest], - #options{object_flags_set = FlagsSet} = Options) -> - %% This option overrides a global setting. - evaluate_options(Rest, Options#options{object_flags_set = - (?ORB_SURVIVE_EXIT bor FlagsSet)}); -evaluate_options([{survive_exit, true}|Rest], - #options{object_flags = Flags, - object_flags_set = FlagsSet} = Options) -> - evaluate_options(Rest, Options#options{object_flags = - (?ORB_SURVIVE_EXIT bor Flags), - object_flags_set = - (?ORB_SURVIVE_EXIT bor FlagsSet)}); -evaluate_options([{local_typecheck, false}|Rest], - #options{object_flags_set = FlagsSet} = Options) -> - %% This option overrides a global setting. - evaluate_options(Rest, Options#options{object_flags_set = - (?ORB_TYPECHECK bor FlagsSet)}); -evaluate_options([{local_typecheck, true}|Rest], - #options{object_flags = Flags, - object_flags_set = FlagsSet} = Options) -> - evaluate_options(Rest, Options#options{object_flags = (?ORB_TYPECHECK bor Flags), - object_flags_set = - (?ORB_TYPECHECK bor FlagsSet)}); -evaluate_options([{local_interceptors, false}|Rest], - #options{object_flags_set = FlagsSet} = Options) -> - %% This option overrides a global setting. - evaluate_options(Rest, Options#options{object_flags_set = - (?ORB_USE_PI bor FlagsSet)}); -evaluate_options([{local_interceptors, true}|Rest], - #options{object_flags = Flags, - object_flags_set = FlagsSet} = Options) -> - evaluate_options(Rest, Options#options{object_flags = (?ORB_USE_PI bor Flags), - object_flags_set = - (?ORB_USE_PI bor FlagsSet)}); -%% Temporary option. -evaluate_options([{no_security, true}|Rest], - #options{object_flags = Flags} = Options) -> - %% We do not allow this option to be set globally. - evaluate_options(Rest, Options#options{object_flags = (?ORB_NO_SECURITY bor Flags)}); -evaluate_options([{no_security, false}|Rest], Options) -> - %% We do not allow this option to be set globally. - evaluate_options(Rest, Options); -evaluate_options([{Key, Value}|_], _) -> - orber:dbg("[~p] corba:evaluate_options(~p, ~p);~n" - "Option not recognized, illegal value or combination.~n" - "Allowed settings:~n" - "survive_exit.......: boolean()~n" - "sup_child..........: boolean()~n" - "persistent.........: boolean()~n" - "pseudo.............: boolean()~n" - "local_typecheck....: boolean()~n" - "local_interceptors.: boolean()~n" - "regname............: {local, atom()} | {global, term()}", - [?LINE, Key, Value], ?DEBUG_LEVEL), - raise(#'BAD_PARAM'{completion_status=?COMPLETED_NO}). - -check_flag(#options{object_flags = Flags, - object_flags_set = FlagsSet} = Options, Flag, - FlagConstant, GlobalFlags) -> - %% Option activated/deactived by a supplied option. - case ?ORB_FLAG_TEST(FlagsSet, Flag) of - true -> - Options; - false -> - %% Not the above. Globally defined? - case ?ORB_FLAG_TEST(GlobalFlags, FlagConstant) of - true -> - Options#options{object_flags = (Flag bor Flags)}; - false -> - Options - end - end. - -%%%%%%%%%%%%%%%%% FOR PASSIVE REPLICATION! -% Note should be called inside transaction. Does not catch exceptions. -% let's not allow corba:reply from transaction... (no {noreply, ...} messages) -% should the object be able to stop itself by returning {stop, ...}? -% how about corba:dispose then? Deleting table representing object group and -% corresponding entry in ft_replication_manager -table might just do the job? -% No {stop, ...} messages for now -% Exceptions falls through. They are expected to be caught by transaction in a -% form of {aborted, {throw, {'EXCEPTION', ...}}} -call_passive(Module, Obj, Func, Args, GroupID) -> - [Record] = mnesia:read(ft_replicated_object, GroupID, sticky_write), - State = Record#ft_replicated_object.state, - - case apply(Module, Func, [Obj, State|Args]) of - {reply, Reply, NewState} -> - {Reply, NewState}; - {reply, Reply, NewState, _} -> - {Reply, NewState} - end, - mnesia:write(ft_replicated_object, - #ft_replicated_object{group_id = GroupID, state = NewState}, - sticky_write), - Reply. - - - -% FTRequestCtx protected object call -% One should protect agains aged reply. If expirations_time is reached and -% request is retransmitted, one might return BAD_CONTEXT -exception! -call_RQprotected(Module, Obj, Func, Args, GroupID, RQCtx) -> - case mnesia:read(ft_reply_retention, RQCtx, sticky_write) of - % fresh request - [] -> - Reply = call_passive(Module, Obj, Func, Args, GroupID), - mnesia:write(ft_reply_retention, - #ft_reply_retention{retention_id= RQCtx,reply= Reply}, - sticky_write), - Reply; - % retransmitted request - #ft_reply_retention{reply = Reply} -> - Reply - end. - - - -% call_primary_protected. Protects agains calling non-primary node. -% normal case, without FTRequest Service Context -call_primary_protected(#ft_replication_manager{primary = Primary}, - Module, - Obj, - Func, - Args, - GroupID, - []) when Primary == node() -> - call_passive(Module, Obj, Func, Args, GroupID); -% normal case, with FTRequest Service Context -call_primary_protected(#ft_replication_manager{primary = Primary}, - Module, - Obj, - Func, - Args, - GroupID, - RetentionID) when Primary == node() -> - call_RQprotected(Module, Obj, Func, Args, GroupID, RetentionID); -% case where primary resides in another node -call_primary_protected(#ft_replication_manager{primary = Primary, - iogr = IOGR}, - _Module, _Obj, _Func, _Args, _GroupID, _) -> - mnesia:abort({not_primary, Primary, IOGR}). - - - -% no context -check_version_context(_, []) -> - ok; -% client's IOGR is current. -check_version_context(#ft_replication_manager{ref_version = CurrentVer}, - GroupVer) when CurrentVer == GroupVer -> - ok; -% client's IOGR is old. -check_version_context(#ft_replication_manager{ref_version = CurrentVer, - iogr = IOGR}, - GroupVer) when CurrentVer > GroupVer -> - mnesia:abort({too_old_reference, IOGR}); -% client's IOGR is too new! -check_version_context(#ft_replication_manager{ref_version = CurrentVer}, - GroupVer) when CurrentVer < GroupVer -> - raise(#'INV_OBJREF'{completion_status = ?COMPLETED_NO}). - - - -read_object_group(GroupID) -> - case mnesia:read({ft_replication_manager, GroupID}) of - [] -> - raise(#'OBJECT_NOT_EXIST'{completion_status = ?COMPLETED_NO}); - [ObjectGroup] -> - ObjectGroup - end. - - - -mk_FTRequestCtx(Expiration_time) -> - #'FT_FTRequestServiceContext'{ - client_id = atom_to_list(node()), - retention_id = orber_request_number:get(), - expiration_time = Expiration_time}. - - - -get_FTRequestCtx([#'FT_FTRequestServiceContext' - {client_id = Client_ID, retention_id = Retention_ID, - expiration_time = Expiration_time}|_Ctxs]) -> - {Client_ID, Retention_ID, Expiration_time}; -get_FTRequestCtx([]) -> - []; -get_FTRequestCtx([_Ctx|Ctxs]) -> - get_FTRequestCtx(Ctxs). - - - -get_FTGroupVersionCtx([#'FT_FTGroupVersionServiceContext' - {object_group_ref_version = Version}|_Ctxs]) -> - Version; -get_FTGroupVersionCtx([]) -> - []; -get_FTGroupVersionCtx([_Ctx|Ctxs]) -> - get_FTGroupVersionCtx(Ctxs). - |