diff options
Diffstat (limited to 'erts/preloaded')
| -rw-r--r-- | erts/preloaded/Makefile | 25 | ||||
| -rw-r--r-- | erts/preloaded/ebin/erl_prim_loader.beam | bin | 0 -> 48420 bytes | |||
| -rw-r--r-- | erts/preloaded/ebin/erlang.beam | bin | 0 -> 23232 bytes | |||
| -rw-r--r-- | erts/preloaded/ebin/init.beam | bin | 0 -> 44460 bytes | |||
| -rw-r--r-- | erts/preloaded/ebin/otp_ring0.beam | bin | 0 -> 1392 bytes | |||
| -rw-r--r-- | erts/preloaded/ebin/prim_file.beam | bin | 0 -> 29480 bytes | |||
| -rw-r--r-- | erts/preloaded/ebin/prim_inet.beam | bin | 0 -> 57308 bytes | |||
| -rw-r--r-- | erts/preloaded/ebin/prim_zip.beam | bin | 0 -> 20756 bytes | |||
| -rw-r--r-- | erts/preloaded/ebin/zlib.beam | bin | 0 -> 10624 bytes | |||
| -rw-r--r-- | erts/preloaded/src/Makefile | 105 | ||||
| -rw-r--r-- | erts/preloaded/src/erl_prim_loader.erl | 1406 | ||||
| -rw-r--r-- | erts/preloaded/src/erlang.erl | 683 | ||||
| -rw-r--r-- | erts/preloaded/src/init.erl | 1372 | ||||
| -rw-r--r-- | erts/preloaded/src/otp_ring0.erl | 35 | ||||
| -rw-r--r-- | erts/preloaded/src/prim_file.erl | 1168 | ||||
| -rw-r--r-- | erts/preloaded/src/prim_inet.erl | 1962 | ||||
| -rw-r--r-- | erts/preloaded/src/prim_zip.erl | 604 | ||||
| -rw-r--r-- | erts/preloaded/src/zip_internal.hrl | 103 | ||||
| -rw-r--r-- | erts/preloaded/src/zlib.erl | 421 |
19 files changed, 7884 insertions, 0 deletions
diff --git a/erts/preloaded/Makefile b/erts/preloaded/Makefile new file mode 100644 index 0000000000..4235a7fe57 --- /dev/null +++ b/erts/preloaded/Makefile @@ -0,0 +1,25 @@ +# +# %CopyrightBegin% +# +# Copyright Ericsson AB 2008-2009. All Rights Reserved. +# +# The contents of this file are subject to the Erlang Public License, +# Version 1.1, (the "License"); you may not use this file except in +# compliance with the License. You should have received a copy of the +# Erlang Public License along with this software. If not, it can be +# retrieved online at http://www.erlang.org/. +# +# Software distributed under the License is distributed on an "AS IS" +# basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +# the License for the specific language governing rights and limitations +# under the License. +# +# %CopyrightEnd% +# +include $(ERL_TOP)/make/target.mk + + +SUB_DIRECTORIES = src + +include $(ERL_TOP)/make/otp_subdir.mk + diff --git a/erts/preloaded/ebin/erl_prim_loader.beam b/erts/preloaded/ebin/erl_prim_loader.beam Binary files differnew file mode 100644 index 0000000000..a031c90188 --- /dev/null +++ b/erts/preloaded/ebin/erl_prim_loader.beam diff --git a/erts/preloaded/ebin/erlang.beam b/erts/preloaded/ebin/erlang.beam Binary files differnew file mode 100644 index 0000000000..39452f53d6 --- /dev/null +++ b/erts/preloaded/ebin/erlang.beam diff --git a/erts/preloaded/ebin/init.beam b/erts/preloaded/ebin/init.beam Binary files differnew file mode 100644 index 0000000000..7b6bafd1af --- /dev/null +++ b/erts/preloaded/ebin/init.beam diff --git a/erts/preloaded/ebin/otp_ring0.beam b/erts/preloaded/ebin/otp_ring0.beam Binary files differnew file mode 100644 index 0000000000..af44a8c9b9 --- /dev/null +++ b/erts/preloaded/ebin/otp_ring0.beam diff --git a/erts/preloaded/ebin/prim_file.beam b/erts/preloaded/ebin/prim_file.beam Binary files differnew file mode 100644 index 0000000000..9391aa45cd --- /dev/null +++ b/erts/preloaded/ebin/prim_file.beam diff --git a/erts/preloaded/ebin/prim_inet.beam b/erts/preloaded/ebin/prim_inet.beam Binary files differnew file mode 100644 index 0000000000..b7be06e6bc --- /dev/null +++ b/erts/preloaded/ebin/prim_inet.beam diff --git a/erts/preloaded/ebin/prim_zip.beam b/erts/preloaded/ebin/prim_zip.beam Binary files differnew file mode 100644 index 0000000000..6e1230d649 --- /dev/null +++ b/erts/preloaded/ebin/prim_zip.beam diff --git a/erts/preloaded/ebin/zlib.beam b/erts/preloaded/ebin/zlib.beam Binary files differnew file mode 100644 index 0000000000..4d9996cc74 --- /dev/null +++ b/erts/preloaded/ebin/zlib.beam diff --git a/erts/preloaded/src/Makefile b/erts/preloaded/src/Makefile new file mode 100644 index 0000000000..785ad531f3 --- /dev/null +++ b/erts/preloaded/src/Makefile @@ -0,0 +1,105 @@ +# +# %CopyrightBegin% +# +# Copyright Ericsson AB 2008-2009. All Rights Reserved. +# +# The contents of this file are subject to the Erlang Public License, +# Version 1.1, (the "License"); you may not use this file except in +# compliance with the License. You should have received a copy of the +# Erlang Public License along with this software. If not, it can be +# retrieved online at http://www.erlang.org/. +# +# Software distributed under the License is distributed on an "AS IS" +# basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +# the License for the specific language governing rights and limitations +# under the License. +# +# %CopyrightEnd% +# +# Note, this makefile is not called during normal build process, it should +# be used when the preloaded modules actually are to be updated (i.e. the +# beam files are to be recompiled, which is normally not done). +# The beam files are placed in the current directory and should be copied +# to the ../ebin directory by using the commit target (only works in +# clearcase). + +include $(ERL_TOP)/make/target.mk +include $(ERL_TOP)/make/$(TARGET)/otp.mk + +EBIN=. + +STATIC_EBIN=../ebin + +include $(ERL_TOP)/erts/vsn.mk +include $(ERL_TOP)/lib/kernel/vsn.mk + +PRE_LOADED_MODULES = \ + erl_prim_loader \ + init \ + prim_file \ + prim_inet \ + zlib \ + prim_zip \ + otp_ring0 \ + erlang + +RELSYSDIR = $(RELEASE_PATH)/lib/erts-$(VSN) +# not $(RELEASE_PATH)/erts-$(VSN)/preloaded + +ERL_FILES= $(PRE_LOADED_MODULES:%=%.erl) + +TARGET_FILES = $(PRE_LOADED_MODULES:%=$(EBIN)/%.$(EMULATOR)) +STATIC_TARGET_FILES = $(PRE_LOADED_MODULES:%=$(STATIC_EBIN)/%.$(EMULATOR)) + +KERNEL_SRC=$(ERL_TOP)/lib/kernel/src +KERNEL_INCLUDE=$(ERL_TOP)/lib/kernel/include +STDLIB_INCLUDE=$(ERL_TOP)/lib/stdlib/include + +ERL_COMPILE_FLAGS += +warn_obsolete_guard -I$(KERNEL_SRC) -I$(KERNEL_INCLUDE) + +debug opt: $(TARGET_FILES) + +clean: + rm -f $(TARGET_FILES) + +prepare: + cleartool co -nc $(STATIC_EBIN)/* + cleartool co -nc $(STATIC_EBIN) + +copy: + for x in *.beam; do\ + if test '!' -f $(STATIC_EBIN)/$$x; then\ + cleartool mkelem -nc $$x;\ + fi;\ + done + cp *.beam $(STATIC_EBIN) + +commit: + cleartool ci -ident -nc $(STATIC_EBIN)/*.beam + cleartool ci -ident -nc $(STATIC_EBIN) + +cancel: + -cleartool unco -rm $(STATIC_EBIN) + -cleartool unco -rm $(STATIC_EBIN)/*.beam + + +include $(ERL_TOP)/make/otp_release_targets.mk + +release_spec: + $(INSTALL_DIR) $(RELSYSDIR)/src + $(INSTALL_DATA) $(ERL_FILES) $(RELSYSDIR)/src + $(INSTALL_DIR) $(RELSYSDIR)/ebin + $(INSTALL_DATA) $(STATIC_TARGET_FILES) $(RELSYSDIR)/ebin + +release_docs_spec: + + +list_preloaded: + @echo $(PRE_LOADED_MODULES) + +# Include dependencies -- list below added by PaN +$(EBIN)/erl_prim_loader.beam: $(KERNEL_SRC)/inet_boot.hrl $(KERNEL_INCLUDE)/file.hrl +$(EBIN)/prim_file.beam: $(KERNEL_INCLUDE)/file.hrl +$(EBIN)/prim_inet.beam: $(KERNEL_SRC)/inet_int.hrl $(KERNEL_INCLUDE)/inet_sctp.hrl +$(EBIN)/prim_zip.beam: zip_internal.hrl $(KERNEL_INCLUDE)/file.hrl $(STDLIB_INCLUDE)/zip.hrl +$(EBIN)/init.erl: $(KERNEL_INCLUDE)/file.hrl diff --git a/erts/preloaded/src/erl_prim_loader.erl b/erts/preloaded/src/erl_prim_loader.erl new file mode 100644 index 0000000000..399c2bb55d --- /dev/null +++ b/erts/preloaded/src/erl_prim_loader.erl @@ -0,0 +1,1406 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1996-2009. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% + +%% A primary loader, provides two different methods to fetch a file: +%% efile and inet. The efile method is simple communication with a +%% port program. +%% +%% The distribution loading was removed and replaced with +%% inet loading +%% +%% The start_it/4 function initializes a record with callback +%% functions used to handle the interface functions. +%% + +-module(erl_prim_loader). + +%% If the macro DEBUG is defined during compilation, +%% debug printouts are done through erlang:display/1. +%% Activate this feature by starting the compiler +%% with> erlc -DDEBUG ... +%% or by> setenv ERL_COMPILER_FLAGS DEBUG +%% before running make (in the OTP make system) +%% (the example is for tcsh) + +-include("inet_boot.hrl"). + +%% Public +-export([start/3, set_path/1, get_path/0, get_file/1, get_files/2, + list_dir/1, read_file_info/1, get_cwd/0, get_cwd/1]). + +%% Used by erl_boot_server +-export([prim_init/0, prim_get_file/2, prim_list_dir/2, + prim_read_file_info/2, prim_get_cwd/2]). + +%% Used by escript and code +-export([set_primary_archive/2, release_archives/0]). + +%% Internal function. Exported to avoid dialyzer warnings +-export([concat/1]). + +-include_lib("kernel/include/file.hrl"). + +-type host() :: atom(). + +-record(state, + {loader :: 'efile' | 'inet', + hosts = [] :: [host()], % hosts list (to boot from) + id, % not used any more? + data, % data port etc + timeout, % idle timeout + n_timeouts, % Number of timeouts before archives are released + multi_get = false :: boolean(), + prim_state}). % state for efile code loader + +-define(IDLE_TIMEOUT, 60000). %% tear inet connection after 1 minutes +-define(N_TIMEOUTS, 6). %% release efile archive after 6 minutes + +%% Defines for inet as prim_loader +-define(INET_FAMILY, inet). +-define(INET_ADDRESS, {0,0,0,0}). + +-ifdef(DEBUG). +-define(dbg(Tag, Data), erlang:display({Tag,Data})). +-else. +-define(dbg(Tag, Data), true). +-endif. + +-define(SAFE2(Expr, State), + fun() -> + case catch Expr of + {'EXIT',XXXReason} -> {{error,XXXReason}, State}; + XXXRes -> XXXRes + end + end()). + +-record(prim_state, {debug, cache, primary_archive}). + +debug(#prim_state{debug = Deb}, Term) -> + case Deb of + false -> ok; + true -> erlang:display(Term) + end. + +%%% -------------------------------------------------------- +%%% Interface Functions. +%%% -------------------------------------------------------- + +-spec start(term(), atom() | string(), host() | [host()]) -> + {'ok', pid()} | {'error', term()}. +start(Id, Pgm, Hosts) when is_atom(Hosts) -> + start(Id, Pgm, [Hosts]); +start(Id, Pgm0, Hosts) -> + Pgm = if + is_atom(Pgm0) -> + atom_to_list(Pgm0); + true -> + Pgm0 + end, + Self = self(), + Pid = spawn_link(fun() -> start_it(Pgm, Id, Self, Hosts) end), + register(erl_prim_loader, Pid), + receive + {Pid,ok} -> + {ok,Pid}; + {'EXIT',Pid,Reason} -> + {error,Reason} + end. + +start_it("ose_inet"=Cmd, Id, Pid, Hosts) -> + %% Setup reserved port for ose_inet driver (only OSE) + case catch erlang:open_port({spawn,Cmd},[binary]) of + {'EXIT',Why} -> + ?dbg(ose_inet_port_open_fail, Why), + Why; + OseInetPort -> + ?dbg(ose_inet_port, OseInetPort), + OseInetPort + end, + start_it("inet", Id, Pid, Hosts); + +%% Hosts must be a list on form ['1.2.3.4' ...] +start_it("inet", Id, Pid, Hosts) -> + process_flag(trap_exit, true), + ?dbg(inet, {Id,Pid,Hosts}), + AL = ipv4_list(Hosts), + ?dbg(addresses, AL), + {ok,Tcp} = find_master(AL), + init_ack(Pid), + PS = prim_init(), + State = #state {loader = inet, + hosts = AL, + id = Id, + data = Tcp, + timeout = ?IDLE_TIMEOUT, + n_timeouts = ?N_TIMEOUTS, + prim_state = PS}, + loop(State, Pid, []); + +start_it("efile", Id, Pid, _Hosts) -> + process_flag(trap_exit, true), + {ok, Port} = prim_file:open([binary]), + init_ack(Pid), + MultiGet = case erlang:system_info(thread_pool_size) of + 0 -> false; + _ -> true + end, + PS = prim_init(), + State = #state {loader = efile, + id = Id, + data = Port, + timeout = infinity, + multi_get = MultiGet, + prim_state = PS}, + loop(State, Pid, []). + +init_ack(Pid) -> + Pid ! {self(),ok}, + ok. + +-spec set_path([string()]) -> 'ok'. +set_path(Paths) when is_list(Paths) -> + request({set_path,Paths}). + +-spec get_path() -> {'ok', [string()]}. +get_path() -> + request({get_path,[]}). + +-spec get_file(atom() | string()) -> {'ok', binary(), string()} | 'error'. +get_file(File) when is_atom(File) -> + get_file(atom_to_list(File)); +get_file(File) -> + check_file_result(get_file, File, request({get_file,File})). + +-spec get_files([{atom(), string()}], + fun((atom(),binary(),string()) -> 'ok' | {'error', atom()})) -> + 'ok' | {'error', atom()}. +get_files(ModFiles, Fun) -> + case request({get_files,{ModFiles,Fun}}) of + E = {error,_M} -> + E; + {error,Reason,M} -> + check_file_result(get_files, M, {error,Reason}), + {error,M}; + ok -> + ok + end. + +-spec list_dir(string()) -> {'ok', [string()]} | 'error'. +list_dir(Dir) -> + check_file_result(list_dir, Dir, request({list_dir,Dir})). + +%% -> {ok,Info} | error +-spec read_file_info(string()) -> {'ok', tuple()} | 'error'. + +read_file_info(File) -> + check_file_result(read_file_info, File, request({read_file_info,File})). + +-spec get_cwd() -> {'ok', string()} | 'error'. +get_cwd() -> + check_file_result(get_cwd, [], request({get_cwd,[]})). + +-spec get_cwd(string()) -> {'ok', string()} | 'error'. +get_cwd(Drive) -> + check_file_result(get_cwd, Drive, request({get_cwd,[Drive]})). + +-spec set_primary_archive(File :: string() | 'undefined', + ArchiveBin :: binary() | 'undefined') + -> {ok, [string()]} | {error,_}. + +set_primary_archive(undefined, undefined) -> + request({set_primary_archive, undefined, undefined}); +set_primary_archive(File, ArchiveBin) + when is_list(File), is_binary(ArchiveBin) -> + request({set_primary_archive, File, ArchiveBin}). + +-spec release_archives() -> 'ok' | {'error', _}. + +release_archives() -> + request(release_archives). + +request(Req) -> + Loader = whereis(erl_prim_loader), + Loader ! {self(),Req}, + receive + {Loader,Res} -> + Res; + {'EXIT',Loader,_What} -> + error + end. + +check_file_result(_, _, {error,enoent}) -> + error; +check_file_result(_, _, {error,enotdir}) -> + error; +check_file_result(Func, Target, {error,Reason}) -> + case (catch atom_to_list(Reason)) of + {'EXIT',_} -> % exit trapped + error; + Errno -> % errno + Process = case process_info(self(), registered_name) of + {registered_name,R} -> + "Process: " ++ atom_to_list(R) ++ "."; + _ -> + "" + end, + TargetStr = + if is_atom(Target) -> atom_to_list(Target); + is_list(Target) -> Target; + true -> [] + end, + Report = + case TargetStr of + [] -> + "File operation error: " ++ Errno ++ ". " ++ + "Function: " ++ atom_to_list(Func) ++ ". " ++ Process; + _ -> + "File operation error: " ++ Errno ++ ". " ++ + "Target: " ++ TargetStr ++ ". " ++ + "Function: " ++ atom_to_list(Func) ++ ". " ++ Process + end, + %% this is equal to calling error_logger:error_report/1 which + %% we don't want to do from code_server during system boot + error_logger ! {notify,{error_report,group_leader(), + {self(),std_error,Report}}}, + error + end; +check_file_result(_, _, Other) -> + Other. + +%%% -------------------------------------------------------- +%%% The main loop. +%%% -------------------------------------------------------- + +loop(State, Parent, Paths) -> + receive + {Pid,Req} when is_pid(Pid) -> + %% erlang:display(Req), + {Resp,State2,Paths2} = + case Req of + {set_path,NewPaths} -> + {ok,State,to_strs(NewPaths)}; + {get_path,_} -> + {{ok,Paths},State,Paths}; + {get_file,File} -> + {Res,State1} = handle_get_file(State, Paths, File), + {Res,State1,Paths}; + {get_files,{ModFiles,Fun}} -> + {Res,State1} = handle_get_files(State, ModFiles, Paths, Fun), + {Res,State1,Paths}; + {list_dir,Dir} -> + {Res,State1} = handle_list_dir(State, Dir), + {Res,State1,Paths}; + {read_file_info,File} -> + {Res,State1} = handle_read_file_info(State, File), + {Res,State1,Paths}; + {get_cwd,[]} -> + {Res,State1} = handle_get_cwd(State, []), + {Res,State1,Paths}; + {get_cwd,[_]=Args} -> + {Res,State1} = handle_get_cwd(State, Args), + {Res,State1,Paths}; + {set_primary_archive,File,Bin} -> + {Res,State1} = handle_set_primary_archive(State, File, Bin), + {Res,State1,Paths}; + release_archives -> + {Res,State1} = handle_release_archives(State), + {Res,State1,Paths}; + _Other -> + {ignore,State,Paths} + end, + if Resp =:= ignore -> ok; + true -> Pid ! {self(),Resp} + end, + if + is_record(State2, state) -> + loop(State2, Parent, Paths2); + true -> + exit({bad_state, Req, State2}) + end; + {'EXIT',Parent,W} -> + handle_stop(State), + exit(W); + {'EXIT',P,W} -> + State1 = handle_exit(State, P, W), + loop(State1, Parent, Paths); + _Message -> + loop(State, Parent, Paths) + after State#state.timeout -> + State1 = handle_timeout(State, Parent), + loop(State1, Parent, Paths) + end. + +handle_get_files(State = #state{multi_get = true}, ModFiles, Paths, Fun) -> + ?SAFE2(efile_multi_get_file_from_port(State, ModFiles, Paths, Fun), State); +handle_get_files(State, _ModFiles, _Paths, _Fun) -> % no multi get + {{error,no_multi_get},State}. + +handle_get_file(State = #state{loader = efile}, Paths, File) -> + ?SAFE2(efile_get_file_from_port(State, File, Paths), State); +handle_get_file(State = #state{loader = inet}, Paths, File) -> + ?SAFE2(inet_get_file_from_port(State, File, Paths), State). + +handle_set_primary_archive(State= #state{loader = efile}, File, Bin) -> + ?SAFE2(efile_set_primary_archive(State, File, Bin), State). + +handle_release_archives(State= #state{loader = efile}) -> + ?SAFE2(efile_release_archives(State), State). + +handle_list_dir(State = #state{loader = efile}, Dir) -> + ?SAFE2(efile_list_dir(State, Dir), State); +handle_list_dir(State = #state{loader = inet}, Dir) -> + ?SAFE2(inet_list_dir(State, Dir), State). + +handle_read_file_info(State = #state{loader = efile}, File) -> + ?SAFE2(efile_read_file_info(State, File), State); +handle_read_file_info(State = #state{loader = inet}, File) -> + ?SAFE2(inet_read_file_info(State, File), State). + +handle_get_cwd(State = #state{loader = efile}, Drive) -> + ?SAFE2(efile_get_cwd(State, Drive), State); +handle_get_cwd(State = #state{loader = inet}, Drive) -> + ?SAFE2(inet_get_cwd(State, Drive), State). + +handle_stop(State = #state{loader = efile}) -> + efile_stop_port(State); +handle_stop(State = #state{loader = inet}) -> + inet_stop_port(State). + +handle_exit(State = #state{loader = efile}, Who, Reason) -> + efile_exit_port(State, Who, Reason); +handle_exit(State = #state{loader = inet}, Who, Reason) -> + inet_exit_port(State, Who, Reason). + +handle_timeout(State = #state{loader = efile}, Parent) -> + efile_timeout_handler(State, Parent); +handle_timeout(State = #state{loader = inet}, Parent) -> + inet_timeout_handler(State, Parent). + +%%% -------------------------------------------------------- +%%% Functions which handles efile as prim_loader (default). +%%% -------------------------------------------------------- + +%%% Reading many files in parallel is an optimization. +%%% See also comment in init.erl. + +%% -> {ok,State} | {{error,Module},State} | {{error,Reason,Module},State} +efile_multi_get_file_from_port(State, ModFiles, Paths, Fun) -> + Ref = make_ref(), + %% More than 200 processes is no gain. + Max = min(200, erlang:system_info(thread_pool_size)), + efile_multi_get_file_from_port2(ModFiles, 0, Max, State, Paths, Fun, Ref, ok). + +efile_multi_get_file_from_port2([MF | MFs], Out, Max, State, Paths, Fun, Ref, Ret) when Out < Max -> + Self = self(), + _Pid = spawn(fun() -> efile_par_get_file(Ref, State, MF, Paths, Self, Fun) end), + efile_multi_get_file_from_port2(MFs, Out+1, Max, State, Paths, Fun, Ref, Ret); +efile_multi_get_file_from_port2(MFs, Out, Max, _State, Paths, Fun, Ref, Ret) when Out > 0 -> + receive + {Ref, ok, State1} -> + efile_multi_get_file_from_port2(MFs, Out-1, Max, State1, Paths, Fun, Ref, Ret); + {Ref, {error,_Mod} = Error, State1} -> + efile_multi_get_file_from_port2(MFs, Out-1, Max, State1, Paths, Fun, Ref, Error); + {Ref, MF, {error,emfile,State1}} -> + %% Max can take negative values. Out cannot. + efile_multi_get_file_from_port2([MF | MFs], Out-1, Max-1, State1, Paths, Fun, Ref, Ret); + {Ref, {M,_F}, {error,Error,State1}} -> + efile_multi_get_file_from_port2(MFs, Out-1, 0, State1, Paths, Fun, Ref, {error,Error,M}) + end; +efile_multi_get_file_from_port2(_MFs, 0, _Max, State, _Paths, _Fun, _Ref, Ret) -> + {Ret,State}. + +efile_par_get_file(Ref, State, {Mod,File} = MF, Paths, Pid, Fun) -> + %% One port for each file read in "parallel": + case prim_file:open([binary]) of + {ok, Port} -> + Port0 = State#state.data, + State1 = State#state{data = Port}, + R = case efile_get_file_from_port(State1, File, Paths) of + {{error,Reason},State2} -> + {Ref,MF,{error,Reason,State2}}; + {{ok,BinFile,Full},State2} -> + %% Fun(...) -> ok | {error,Mod} + {Ref,Fun(Mod, BinFile, Full),State2#state{data=Port0}} + end, + prim_file:close(Port), + Pid ! R; + {error, Error} -> + Pid ! {Ref,MF,{error,Error,State}} + end. + +%% -> {{ok,BinFile,File},State} | {{error,Reason},State} +efile_get_file_from_port(State, File, Paths) -> + case is_basename(File) of + false -> % get absolute file name. + efile_get_file_from_port2(State, File); + true when Paths =:= [] -> % get plain file name. + efile_get_file_from_port2(State, File); + true -> % use paths. + efile_get_file_from_port3(State, File, Paths) + end. + +efile_get_file_from_port2(#state{prim_state = PS} = State, File) -> + {Res, PS2} = prim_get_file(PS, File), + case Res of + {error,port_died} -> + exit('prim_load port died'); + {error,Reason} -> + {{error,Reason},State#state{prim_state = PS2}}; + {ok,BinFile} -> + {{ok,BinFile,File},State#state{prim_state = PS2}} + end. + +efile_get_file_from_port3(State, File, [P | Paths]) -> + case efile_get_file_from_port2(State, concat([P,"/",File])) of + {{error,Reason},State1} when Reason =/= emfile -> + case Paths of + [] -> % return last error + {{error,Reason},State1}; + _ -> % try more paths + efile_get_file_from_port3(State1, File, Paths) + end; + Result -> + Result + end; +efile_get_file_from_port3(State, _File, []) -> + {{error,enoent},State}. + +efile_set_primary_archive(#state{prim_state = PS} = State, File, Bin) -> + {Res, PS2} = prim_set_primary_archive(PS, File, Bin), + {Res,State#state{prim_state = PS2}}. + +efile_release_archives(#state{prim_state = PS} = State) -> + {Res, PS2} = prim_release_archives(PS), + {Res,State#state{prim_state = PS2}}. + +efile_list_dir(#state{prim_state = PS} = State, Dir) -> + {Res, PS2} = prim_list_dir(PS, Dir), + {Res, State#state{prim_state = PS2}}. + +efile_read_file_info(#state{prim_state = PS} = State, File) -> + {Res, PS2} = prim_read_file_info(PS, File), + {Res, State#state{prim_state = PS2}}. + +efile_get_cwd(#state{prim_state = PS} = State, Drive) -> + {Res, PS2} = prim_get_cwd(PS, Drive), + {Res, State#state{prim_state = PS2}}. + +efile_stop_port(#state{data=Port}=State) -> + prim_file:close(Port), + State#state{data=noport}. + +efile_exit_port(State, Port, Reason) when State#state.data =:= Port -> + exit({port_died,Reason}); +efile_exit_port(State, _Port, _Reason) -> + State. + +efile_timeout_handler(#state{n_timeouts = N} = State, _Parent) -> + if + N =< 0 -> + {_Res, State2} = efile_release_archives(State), + State2#state{n_timeouts = ?N_TIMEOUTS}; + true -> + State#state{n_timeouts = N - 1} + end. + +%%% -------------------------------------------------------- +%%% Functions which handles inet prim_loader +%%% -------------------------------------------------------- + +%% +%% Connect to a boot master +%% return {ok, Socket} TCP +%% AL is a list of boot servers (including broadcast addresses) +%% +find_master(AL) -> + find_master(AL, ?EBOOT_RETRY, ?EBOOT_REQUEST_DELAY, ?EBOOT_SHORT_RETRY_SLEEP, + ?EBOOT_UNSUCCESSFUL_TRIES, ?EBOOT_LONG_RETRY_SLEEP). + +find_master(AL, Retry, ReqDelay, SReSleep, Tries, LReSleep) -> + {ok,U} = ll_udp_open(0), + find_master(U, Retry, AL, ReqDelay, SReSleep, [], Tries, LReSleep). + +%% +%% Master connect loop +%% +find_master(U, Retry, AddrL, ReqDelay, SReSleep, Ignore, Tries, LReSleep) -> + case find_loop(U, Retry, AddrL, ReqDelay, SReSleep, Ignore, + Tries, LReSleep) of + [] -> + find_master(U, Retry, AddrL, ReqDelay, SReSleep, Ignore, + Tries, LReSleep); + Servers -> + ?dbg(servers, Servers), + case connect_master(Servers) of + {ok, Socket} -> + ll_close(U), + {ok, Socket}; + _Error -> + find_master(U, Retry, AddrL, ReqDelay, SReSleep, + Servers ++ Ignore, Tries, LReSleep) + end + end. + +connect_master([{_Prio,IP,Port} | Servers]) -> + case ll_tcp_connect(0, IP, Port) of + {ok, S} -> {ok, S}; + _Error -> connect_master(Servers) + end; +connect_master([]) -> + {error, ebusy}. + +%% +%% Always return a list of boot servers or hang. +%% +find_loop(U, Retry, AL, ReqDelay, SReSleep, Ignore, Tries, LReSleep) -> + case find_loop(U, Retry, AL, ReqDelay, []) of + [] -> % no response from any server + erlang:display({erl_prim_loader,'no server found'}), % lifesign + Tries1 = if Tries > 0 -> + sleep(SReSleep), + Tries - 1; + true -> + sleep(LReSleep), + 0 + end, + find_loop(U, Retry, AL, ReqDelay, SReSleep, Ignore, Tries1, LReSleep); + Servers -> + keysort(1, Servers -- Ignore) + end. + +%% broadcast or send +find_loop(_U, 0, _AL, _Delay, Acc) -> + Acc; +find_loop(U, Retry, AL, Delay, Acc) -> + send_all(U, AL, [?EBOOT_REQUEST, erlang:system_info(version)]), + find_collect(U, Retry-1, AL, Delay, Acc). + +find_collect(U,Retry,AL,Delay,Acc) -> + receive + {udp, U, IP, _Port, [$E,$B,$O,$O,$T,$R,Priority,T1,T0 | _Version]} -> + Elem = {Priority,IP,T1*256+T0}, + ?dbg(got, Elem), + case member(Elem, Acc) of + false -> find_collect(U, Retry, AL, Delay, [Elem | Acc]); + true -> find_collect(U, Retry, AL, Delay, Acc) + end; + _Garbage -> + ?dbg(collect_garbage, _Garbage), + find_collect(U, Retry, AL, Delay, Acc) + + after Delay -> + ?dbg(collected, Acc), + case keymember(0, 1, Acc) of %% got high priority server? + true -> Acc; + false -> find_loop(U, Retry, AL, Delay, Acc) + end + end. + + +sleep(Time) -> + receive after Time -> ok end. + +inet_exit_port(State, Port, _Reason) when State#state.data =:= Port -> + State#state { data = noport, timeout = infinity }; +inet_exit_port(State, _, _) -> + State. + + +inet_timeout_handler(State, _Parent) -> + Tcp = State#state.data, + if is_port(Tcp) -> ll_close(Tcp); + true -> ok + end, + State#state { timeout = infinity, data = noport }. + +%% -> {{ok,BinFile,Tag},State} | {{error,Reason},State} +inet_get_file_from_port(State, File, Paths) -> + case is_basename(File) of + false -> % get absolute file name. + inet_send_and_rcv({get,File}, File, State); + true when Paths =:= [] -> % get plain file name. + inet_send_and_rcv({get,File}, File, State); + true -> % use paths. + inet_get_file_from_port1(File, Paths, State) + end. + +inet_get_file_from_port1(File, [P | Paths], State) -> + File1 = concat([P,"/",File]), + case inet_send_and_rcv({get,File1}, File1, State) of + {{error,Reason},State1} -> + case Paths of + [] -> % return last error + {{error,Reason},State1}; + _ -> % try more paths + inet_get_file_from_port1(File, Paths, State1) + end; + Result -> Result + end; +inet_get_file_from_port1(_File, [], State) -> + {{error,file_not_found},State}. + +inet_send_and_rcv(Msg, Tag, State) when State#state.data =:= noport -> + {ok,Tcp} = find_master(State#state.hosts), %% reconnect + inet_send_and_rcv(Msg, Tag, State#state { data = Tcp, + timeout = ?IDLE_TIMEOUT }); +inet_send_and_rcv(Msg, Tag, #state{data=Tcp,timeout=Timeout}=State) -> + prim_inet:send(Tcp, term_to_binary(Msg)), + receive + {tcp,Tcp,BinMsg} -> + case catch binary_to_term(BinMsg) of + {get,{ok,BinFile}} -> + {{ok,BinFile,Tag},State}; + {_Cmd,Res={ok,_}} -> + {Res,State}; + {_Cmd,{error,Error}} -> + {{error,Error},State}; + {error,Error} -> + {{error,Error},State}; + {'EXIT',Error} -> + {{error,Error},State} + end; + {tcp_closed,Tcp} -> + %% Ok we must reconnect + inet_send_and_rcv(Msg, Tag, State#state { data = noport }); + {tcp_error,Tcp,_Reason} -> + %% Ok we must reconnect + inet_send_and_rcv(Msg, Tag, inet_stop_port(State)); + {'EXIT', Tcp, _} -> + %% Ok we must reconnect + inet_send_and_rcv(Msg, Tag, State#state { data = noport }) + after Timeout -> + %% Ok we must reconnect + inet_send_and_rcv(Msg, Tag, inet_stop_port(State)) + end. + +%% -> {{ok,List},State} | {{error,Reason},State} +inet_list_dir(State, Dir) -> + inet_send_and_rcv({list_dir,Dir}, list_dir, State). + +%% -> {{ok,Info},State} | {{error,Reason},State} +inet_read_file_info(State, File) -> + inet_send_and_rcv({read_file_info,File}, read_file_info, State). + +%% -> {{ok,Cwd},State} | {{error,Reason},State} +inet_get_cwd(State, []) -> + inet_send_and_rcv(get_cwd, get_cwd, State); +inet_get_cwd(State, [Drive]) -> + inet_send_and_rcv({get_cwd,Drive}, get_cwd, State). + +inet_stop_port(#state{data=Tcp}=State) -> + prim_inet:close(Tcp), + State#state{data=noport}. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% Direct inet_drv access +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +tcp_options() -> + [{mode,binary}, {packet,4}, {active, true}, {deliver,term}]. + +tcp_timeout() -> + 15000. + +%% options for udp [list, {broadcast, true}, {active,true}] +udp_options() -> + [{mode,list}, {active, true}, {deliver,term}, {broadcast,true}]. +%% +%% INET version IPv4 addresses +%% +ll_tcp_connect(LocalPort, IP, RemotePort) -> + case ll_open_set_bind(tcp, ?INET_FAMILY, tcp_options(), + ?INET_ADDRESS, LocalPort) of + {ok,S} -> + case prim_inet:connect(S, IP, RemotePort, tcp_timeout()) of + ok -> {ok, S}; + Error -> port_error(S, Error) + end; + Error -> Error + end. + +%% +%% Open and initialize an udp port for broadcast +%% +ll_udp_open(P) -> + ll_open_set_bind(udp, ?INET_FAMILY, udp_options(), ?INET_ADDRESS, P). + + +ll_open_set_bind(Protocol, Family, SOpts, IP, Port) -> + case prim_inet:open(Protocol, Family) of + {ok, S} -> + case prim_inet:setopts(S, SOpts) of + ok -> + case prim_inet:bind(S, IP, Port) of + {ok,_} -> + {ok, S}; + Error -> port_error(S, Error) + end; + Error -> port_error(S, Error) + end; + Error -> Error + end. + + +ll_close(S) -> + unlink(S), + exit(S, kill). + +port_error(S, Error) -> + unlink(S), + prim_inet:close(S), + Error. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +prim_init() -> + Deb = + case init:get_argument(loader_debug) of + {ok, _} -> true; + error -> false + end, + cache_new(#prim_state{debug = Deb}). + +prim_release_archives(PS) -> + debug(PS, release_archives), + {Res, PS2}= prim_do_release_archives(PS, get(), []), + debug(PS2, {return, Res}), + {Res, PS2}. + +prim_do_release_archives(PS, [{ArchiveFile, DictVal} | KeyVals], Acc) -> + Res = + case DictVal of + {primary, _PrimZip} -> + ok; % Keep primary archive + {_Mtime, Cache} -> + debug(PS, {release, cache, ArchiveFile}), + erase(ArchiveFile), + clear_cache(ArchiveFile, Cache) + end, + case Res of + ok -> + prim_do_release_archives(PS, KeyVals, Acc); + {error, Reason} -> + prim_do_release_archives(PS, KeyVals, [{ArchiveFile, Reason} | Acc]) + end; +prim_do_release_archives(PS, [], []) -> + {ok, PS#prim_state{primary_archive = undefined}}; +prim_do_release_archives(PS, [], Errors) -> + {{error, Errors}, PS#prim_state{primary_archive = undefined}}. + +prim_set_primary_archive(PS, undefined, undefined) -> + debug(PS, {set_primary_archive, clean}), + case PS#prim_state.primary_archive of + undefined -> + Res = {error, enoent}, + debug(PS, {return, Res}), + {Res, PS}; + ArchiveFile -> + {primary, PrimZip} = erase(ArchiveFile), + ok = prim_zip:close(PrimZip), + PS2 = PS#prim_state{primary_archive = undefined}, + Res = {ok, []}, + debug(PS2, {return, Res}), + {Res, PS2} + end; +prim_set_primary_archive(PS, ArchiveFile, ArchiveBin) + when is_list(ArchiveFile), is_binary(ArchiveBin) -> + %% Try the archive file + debug(PS, {set_primary_archive, ArchiveFile, byte_size(ArchiveBin)}), + {Res3, PS3} = + case PS#prim_state.primary_archive of + undefined -> + Fun = + fun({Funny, _GI, _GB}, A) -> + case Funny of + ["", "nibe", RevApp] -> % Reverse ebin + %% Collect ebin directories in archive + Ebin = reverse(RevApp) ++ "/ebin", + {true, [Ebin | A]}; + _ -> + {true, A} + end + end, + Ebins0 = [ArchiveFile], + case open_archive({ArchiveFile, ArchiveBin}, Ebins0, Fun) of + {ok, PrimZip, RevEbins} -> + Ebins = reverse(RevEbins), + debug(PS, {set_primary_archive, Ebins}), + put(ArchiveFile, {primary, PrimZip}), + {{ok, Ebins}, PS#prim_state{primary_archive = ArchiveFile}}; + Error -> + debug(PS, {set_primary_archive, Error}), + {Error, PS} + end; + OldArchiveFile -> + debug(PS, {set_primary_archive, clean}), + PrimZip = erase(OldArchiveFile), + ok = prim_zip:close(PrimZip), + PS2 = PS#prim_state{primary_archive = undefined}, + prim_set_primary_archive(PS2, ArchiveFile, ArchiveBin) + end, + debug(PS3, {return, Res3}), + {Res3, PS3}. + +prim_get_file(PS, File) -> + debug(PS, {get_file, File}), + {Res2, PS2} = + case name_split(PS#prim_state.primary_archive, File) of + {file, PrimFile} -> + Res = prim_file:read_file(PrimFile), + {Res, PS}; + {archive, ArchiveFile, FileInArchive} -> + debug(PS, {archive_get_file, ArchiveFile, FileInArchive}), + FunnyFile = funny_split(FileInArchive, $/), + Fun = + fun({Funny, _GetInfo, GetBin}, Acc) -> + if + Funny =:= FunnyFile -> + {false, {ok, GetBin()}}; + true -> + {true, Acc} + end + end, + apply_archive(PS, Fun, {error, enoent}, ArchiveFile) + end, + debug(PS, {return, Res2}), + {Res2, PS2}. + +%% -> {{ok,List},State} | {{error,Reason},State} +prim_list_dir(PS, Dir) -> + debug(PS, {list_dir, Dir}), + {Res2, PS3} = + case name_split(PS#prim_state.primary_archive, Dir) of + {file, PrimDir} -> + Res = prim_file:list_dir(PrimDir), + {Res, PS}; + {archive, ArchiveFile, FileInArchive} -> + debug(PS, {archive_list_dir, ArchiveFile, FileInArchive}), + FunnyDir = funny_split(FileInArchive, $/), + Fun = + fun({Funny, _GetInfo, _GetBin}, {Status, Names} = Acc) -> + case Funny of + [RevName | FD] when FD =:= FunnyDir -> + case RevName of + "" -> + %% The listed directory + {true, {ok, Names}}; + _ -> + %% Plain file + Name = reverse(RevName), + {true, {Status, [Name | Names]}} + end; + ["", RevName | FD] when FD =:= FunnyDir -> + %% Directory + Name = reverse(RevName), + {true, {Status, [Name | Names]}}; + [RevName] when FunnyDir =:= [""] -> + %% Top file + Name = reverse(RevName), + {true, {ok, [Name | Names]}}; + ["", RevName] when FunnyDir =:= [""] -> + %% Top file + Name = reverse(RevName), + {true, {ok, [Name | Names]}}; + _ -> + %% No match + {true, Acc} + end + end, + {{Status, Names}, PS2} = + apply_archive(PS, Fun, {error, []}, ArchiveFile), + case Status of + ok -> {{ok, Names}, PS2}; + error -> {{error, enotdir}, PS2} + end + end, + debug(PS, {return, Res2}), + {Res2, PS3}. + +%% -> {{ok,Info},State} | {{error,Reason},State} +prim_read_file_info(PS, File) -> + debug(PS, {read_file_info, File}), + {Res2, PS2} = + case name_split(PS#prim_state.primary_archive, File) of + {file, PrimFile} -> + Res = prim_file:read_file_info(PrimFile), + {Res, PS}; + {archive, ArchiveFile, []} -> + %% Fake top directory + debug(PS, {archive_read_file_info, ArchiveFile}), + case prim_file:read_file_info(ArchiveFile) of + {ok, FI} -> + {{ok, FI#file_info{type = directory}}, PS}; + Other -> + {Other, PS} + end; + {archive, ArchiveFile, FileInArchive} -> + debug(PS, {archive_read_file_info, File}), + FunnyFile = funny_split(FileInArchive, $/), + Fun = + fun({Funny, GetInfo, _GetBin}, Acc) -> + if + hd(Funny) =:= "", + tl(Funny) =:= FunnyFile -> + %% Directory + {false, {ok, GetInfo()}}; + Funny =:= FunnyFile -> + %% Plain file + {false, {ok, GetInfo()}}; + true -> + %% No match + {true, Acc} + end + end, + apply_archive(PS, Fun, {error, enoent}, ArchiveFile) + end, + debug(PS2, {return, Res2}), + {Res2, PS2}. + +prim_get_cwd(PS, []) -> + debug(PS, {get_cwd, []}), + Res = prim_file:get_cwd(), + debug(PS, {return, Res}), + {Res, PS}; +prim_get_cwd(PS, [Drive]) -> + debug(PS, {get_cwd, Drive}), + Res = prim_file:get_cwd(Drive), + debug(PS, {return, Res}), + {Res, PS}. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +apply_archive(PS, Fun, Acc, Archive) -> + case get(Archive) of + undefined -> + case prim_file:read_file_info(Archive) of + {ok, #file_info{mtime = Mtime}} -> + case open_archive(Archive, Acc, Fun) of + {ok, PrimZip, Acc2} -> + debug(PS, {cache, ok}), + put(Archive, {Mtime, {ok, PrimZip}}), + {Acc2, PS}; + Error -> + debug(PS, {cache, Error}), + put(Archive, {Mtime, Error}), + {Error, PS} + end; + Error -> + debug(PS, {cache, Error}), + {Error, PS} + end; + {primary, PrimZip} -> + case foldl_archive(PrimZip, Acc, Fun) of + {ok, _PrimZip2, Acc2} -> + {Acc2, PS}; + Error -> + debug(PS, {primary, Error}), + {Error, PS} + end; + {Mtime, Cache} -> + case prim_file:read_file_info(Archive) of + {ok, #file_info{mtime = Mtime2}} when Mtime2 =:= Mtime -> + case Cache of + {ok, PrimZip} -> + case foldl_archive(PrimZip, Acc, Fun) of + {ok, _PrimZip2, Acc2} -> + {Acc2, PS}; + Error -> + debug(PS, {cache, {clear, Error}}), + clear_cache(Archive, Cache), + debug(PS, {cache, Error}), + put(Archive, {Mtime, Error}), + {Error, PS} + end; + Error -> + debug(PS, {cache, Error}), + {Error, PS} + end; + Error -> + debug(PS, {cache, {clear, Error}}), + clear_cache(Archive, Cache), + apply_archive(PS, Fun, Acc, Archive) + end + end. + +open_archive(Archive, Acc, Fun) -> + Wrapper = + fun({N, GI, GB}, A) -> + %% Ensure full iteration at open + Funny = funny_split(N, $/), + {_Continue, A2} = Fun({Funny, GI, GB}, A), + {true, {true, Funny}, A2} + end, + prim_zip:open(Wrapper, Acc, Archive). + +foldl_archive(PrimZip, Acc, Fun) -> + Wrapper = + fun({N, GI, GB}, A) -> + %% Allow partial iteration at foldl + {Continue, A2} = Fun({N, GI, GB}, A), + {Continue, true, A2} + end, + prim_zip:foldl(Wrapper, Acc, PrimZip). + +cache_new(PS) -> + PS. + +clear_cache(Archive, Cache) -> + erase(Archive), + case Cache of + {ok, PrimZip} -> + prim_zip:close(PrimZip); + {error, _} -> + ok + end. + +%%% -------------------------------------------------------- +%%% Misc. functions. +%%% -------------------------------------------------------- + +%%% Look for directory separators +is_basename(File) -> + case deep_member($/, File) of + true -> + false; + false -> + case erlang:system_info(os_type) of + {win32, _} -> + case File of + [_,$: | _] -> + false; + _ -> + not deep_member($\\, File) + end; + _ -> + true + end + end. + +send_all(U, [IP | AL], Cmd) -> + ?dbg(sendto, {U, IP, ?EBOOT_PORT, Cmd}), + prim_inet:sendto(U, IP, ?EBOOT_PORT, Cmd), + send_all(U, AL, Cmd); +send_all(_U, [], _) -> ok. + +concat([A|T]) when is_atom(A) -> %Atom + atom_to_list(A) ++ concat(T); +concat([C|T]) when C >= 0, C =< 255 -> + [C|concat(T)]; +concat([S|T]) -> %String + S ++ concat(T); +concat([]) -> + []. + +member(X, [X|_]) -> true; +member(X, [_|Y]) -> member(X, Y); +member(_X, []) -> false. + +deep_member(X, [X|_]) -> + true; +deep_member(X, [List | Y]) when is_list(List) -> + deep_member(X, List) orelse deep_member(X, Y); +deep_member(X, [Atom | Y]) when is_atom(Atom) -> + deep_member(X, atom_to_list(Atom)) orelse deep_member(X, Y); +deep_member(X, [_ | Y]) -> + deep_member(X, Y); +deep_member(_X, []) -> + false. + +keymember(X, I, [Y | _]) when element(I,Y) =:= X -> true; +keymember(X, I, [_ | T]) -> keymember(X, I, T); +keymember(_X, _I, []) -> false. + +keysort(I, L) -> keysort(I, L, []). + +keysort(I, [X | L], Ls) -> + keysort(I, L, keyins(X, I, Ls)); +keysort(_I, [], Ls) -> Ls. + +keyins(X, I, [Y | T]) when X < element(I,Y) -> [X,Y|T]; +keyins(X, I, [Y | T]) -> [Y | keyins(X, I, T)]; +keyins(X, _I, []) -> [X]. + +min(X, Y) when X < Y -> X; +min(_X, Y) -> Y. + +to_strs([P|Paths]) when is_atom(P) -> + [atom_to_list(P)|to_strs(Paths)]; +to_strs([P|Paths]) when is_list(P) -> + [P|to_strs(Paths)]; +to_strs([_|Paths]) -> + to_strs(Paths); +to_strs([]) -> + []. + +reverse([] = L) -> + L; +reverse([_] = L) -> + L; +reverse([A, B]) -> + [B, A]; +reverse([A, B | L]) -> + lists:reverse(L, [B, A]). % BIF + +%% Returns all lists in reverse order +funny_split(List, Sep) -> + funny_split(List, Sep, [], []). + +funny_split([Sep | Tail], Sep, Path, Paths) -> + funny_split(Tail, Sep, [], [Path | Paths]); +funny_split([Head | Tail], Sep, Path, Paths) -> + funny_split(Tail, Sep, [Head | Path], Paths); +funny_split([], _Sep, Path, Paths) -> + [Path | Paths]. + +name_split(ArchiveFile, File0) -> + File = absname(File0), + do_name_split(ArchiveFile, File). + +do_name_split(undefined, File) -> + %% Ignore primary archive + case string_split(File, init:archive_extension(), []) of + no_split -> + %% Plain file + {file, File}; + {split, _RevArchiveBase, RevArchiveFile, []} -> + %% Top dir in archive + ArchiveFile = reverse(RevArchiveFile), + {archive, ArchiveFile, []}; + {split, _RevArchiveBase, RevArchiveFile, [$/ | FileInArchive]} -> + %% File in archive + ArchiveFile = reverse(RevArchiveFile), + {archive, ArchiveFile, FileInArchive}; + {split, _RevArchiveBase, _RevArchiveFile, _FileInArchive} -> + %% False match. Assume plain file + {file, File} + end; +do_name_split(ArchiveFile0, File) -> + %% Look first in primary archive + ArchiveFile = absname(ArchiveFile0), + case string_match(File, ArchiveFile, []) of + no_match -> + %% Archive or plain file + do_name_split(undefined, File); + {match, _RevPrimArchiveFile, FileInArchive} -> + %% Primary archive + case FileInArchive of + [$/ | FileInArchive2] -> + {archive, ArchiveFile, FileInArchive2}; + _ -> + {archive, ArchiveFile, FileInArchive} + end + end. + +string_match([Char | File], [Char | Archive], RevTop) -> + string_match(File, Archive, [Char | RevTop]); +string_match(File, [], RevTop) -> + {match, RevTop, File}; +string_match(_File, _Archive, _RevTop) -> + no_match. + +string_split([Char | File], [Char | Ext] = FullExt, RevTop) -> + RevTop2 = [Char | RevTop], + string_split2(File, Ext, RevTop, RevTop2, File, FullExt, RevTop2); +string_split([Char | File], Ext, RevTop) -> + string_split(File, Ext, [Char | RevTop]); +string_split([], _Ext, _RevTop) -> + no_split. + +string_split2([Char | File], [Char | Ext], RevBase, RevTop, SaveFile, SaveExt, SaveTop) -> + string_split2(File, Ext, RevBase, [Char | RevTop], SaveFile, SaveExt, SaveTop); +string_split2(File, [], RevBase, RevTop, _SaveFile, _SaveExt, _SaveTop) -> + {split, RevBase, RevTop, File}; +string_split2(_, _Ext, _RevBase, _RevTop, SaveFile, SaveExt, SaveTop) -> + string_split(SaveFile, SaveExt, SaveTop). + +%% Parse list of ipv4 addresses +ipv4_list([H | T]) -> + IPV = if is_atom(H) -> ipv4_address(atom_to_list(H)); + is_list(H) -> ipv4_address(H); + true -> {error,einal} + end, + case IPV of + {ok,IP} -> [IP | ipv4_list(T)]; + _ -> ipv4_list(T) + end; +ipv4_list([]) -> []. + +%% +%% Parse Ipv4 address: d1.d2.d3.d4 (from inet_parse) +%% +%% Return {ok, IP} | {error, einval} +%% +ipv4_address(Cs) -> + case catch ipv4_addr(Cs, []) of + {'EXIT',_} -> {error,einval}; + Addr -> {ok,Addr} + end. + +ipv4_addr([C | Cs], IP) when C >= $0, C =< $9 -> ipv4_addr(Cs, C-$0, IP). + +ipv4_addr([$.|Cs], N, IP) when N < 256 -> ipv4_addr(Cs, [N|IP]); +ipv4_addr([C|Cs], N, IP) when C >= $0, C =< $9 -> + ipv4_addr(Cs, N*10 + (C-$0), IP); +ipv4_addr([], D, [C,B,A]) when D < 256 -> {A,B,C,D}. + +%% A simplified version of filename:absname/1 +absname(Name) -> + Name2 = normalize(Name, []), + case pathtype(Name2) of + absolute -> + Name2; + relative -> + case prim_file:get_cwd() of + {ok, Cwd} -> + Cwd ++ "/" ++ Name2; + {error, _} -> + Name2 + end; + volumerelative -> + case prim_file:get_cwd() of + {ok, Cwd} -> + absname_vr(Name2, Cwd); + {error, _} -> + Name2 + end + end. + +%% Assumes normalized name +absname_vr([$/ | NameRest], [Drive, $\: | _]) -> + %% Absolute path on current drive. + [Drive, $\: | NameRest]; +absname_vr([Drive, $\: | NameRest], [Drive, $\: | _] = Cwd) -> + %% Relative to current directory on current drive. + Cwd ++ "/" ++ NameRest; +absname_vr([Drive, $\: | NameRest], _) -> + %% Relative to current directory on another drive. + case prim_file:get_cwd([Drive, $\:]) of + {ok, DriveCwd} -> + DriveCwd ++ "/" ++ NameRest; + {error, _} -> + [Drive, $\:, $/] ++ NameRest + end. + +%% Assumes normalized name +pathtype(Name) when is_list(Name) -> + case erlang:system_info(os_type) of + {unix, _} -> + unix_pathtype(Name); + {win32, _} -> + win32_pathtype(Name); + {vxworks, _} -> + case vxworks_first(Name) of + {device, _Rest, _Dev} -> + absolute; + _ -> + relative + end; + {ose,_} -> + unix_pathtype(Name) + end. + +unix_pathtype(Name) -> + case Name of + [$/|_] -> + absolute; + [List|Rest] when is_list(List) -> + unix_pathtype(List++Rest); + [Atom|Rest] when is_atom(Atom) -> + atom_to_list(Atom)++Rest; + _ -> + relative + end. + +win32_pathtype(Name) -> + case Name of + [List|Rest] when is_list(List) -> + win32_pathtype(List++Rest); + [Atom|Rest] when is_atom(Atom) -> + win32_pathtype(atom_to_list(Atom)++Rest); + [Char, List | Rest] when is_list(List) -> + win32_pathtype([Char | List++Rest]); + [$/, $/|_] -> + absolute; + [$\\, $/|_] -> + absolute; + [$/, $\\|_] -> + absolute; + [$\\, $\\|_] -> + absolute; + [$/|_] -> + volumerelative; + [$\\|_] -> + volumerelative; + [C1, C2, List | Rest] when is_list(List) -> + pathtype([C1, C2|List ++ Rest]); + [_Letter, $:, $/|_] -> + absolute; + [_Letter, $:, $\\|_] -> + absolute; + [_Letter, $:|_] -> + volumerelative; + _ -> + relative + end. + +vxworks_first(Name) -> + case Name of + [] -> + {not_device, [], []}; + [$/ | T] -> + vxworks_first2(device, T, [$/]); + [$\\ | T] -> + vxworks_first2(device, T, [$/]); + [H | T] when is_list(H) -> + vxworks_first(H ++ T); + [H | T] -> + vxworks_first2(not_device, T, [H]) + end. + +vxworks_first2(Devicep, Name, FirstComp) -> + case Name of + [] -> + {Devicep, [], FirstComp}; + [$/ |T ] -> + {Devicep, [$/ | T], FirstComp}; + [$\\ | T] -> + {Devicep, [$/ | T], FirstComp}; + [$: | T]-> + {device, T, [$: | FirstComp]}; + [H | T] when is_list(H) -> + vxworks_first2(Devicep, H ++ T, FirstComp); + [H | T] -> + vxworks_first2(Devicep, T, [H | FirstComp]) + end. + +normalize(Name, Acc) -> + case Name of + [List | Rest] when is_list(List) -> + normalize(List ++ Rest, Acc); + [Atom | Rest] when is_atom(Atom) -> + normalize(atom_to_list(Atom) ++ Rest, Acc); + [$\\ | Chars] -> + normalize(Chars, [$/ | Acc]); + [Char | Chars] -> + normalize(Chars, [Char | Acc]); + [] -> + reverse(Acc) + end. diff --git a/erts/preloaded/src/erlang.erl b/erts/preloaded/src/erlang.erl new file mode 100644 index 0000000000..6f92b319b7 --- /dev/null +++ b/erts/preloaded/src/erlang.erl @@ -0,0 +1,683 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1996-2009. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% +-module(erlang). + +-export([apply/2,apply/3,spawn/4,spawn_link/4, + spawn_monitor/1,spawn_monitor/3, + spawn_opt/2,spawn_opt/3,spawn_opt/4,spawn_opt/5, + disconnect_node/1]). +-export([spawn/1, spawn_link/1, spawn/2, spawn_link/2]). +-export([yield/0]). +-export([crasher/6]). +-export([fun_info/1]). +-export([send_nosuspend/2, send_nosuspend/3]). +-export([localtime_to_universaltime/1]). +-export([suspend_process/1]). +-export([min/2,max/2]). + +-export([dlink/1, dunlink/1, dsend/2, dsend/3, dgroup_leader/2, + dexit/2, dmonitor_node/3, dmonitor_p/2]). + +-export([delay_trap/2]). + +-export([set_cookie/2, get_cookie/0]). + +-export([nodes/0]). + +-export([concat_binary/1]). + +-export([list_to_integer/2,integer_to_list/2]). + +-export([flush_monitor_message/2]). + +-export([set_cpu_topology/1, format_cpu_topology/1]). + +-export([await_proc_exit/3]). + +-deprecated([hash/2]). + +-compile(nowarn_bif_clash). + +apply(Fun, Args) -> + apply(Fun, Args). + +apply(Mod, Name, Args) -> + apply(Mod, Name, Args). + + +% Spawns with a fun +spawn(F) when is_function(F) -> + spawn(erlang, apply, [F, []]); +spawn({M,F}=MF) when is_atom(M), is_atom(F) -> + spawn(erlang, apply, [MF, []]); +spawn(F) -> + erlang:error(badarg, [F]). + +spawn(N, F) when N =:= node() -> + spawn(F); +spawn(N, F) when is_function(F) -> + spawn(N, erlang, apply, [F, []]); +spawn(N, {M,F}=MF) when is_atom(M), is_atom(F) -> + spawn(N, erlang, apply, [MF, []]); +spawn(N, F) -> + erlang:error(badarg, [N, F]). + +spawn_link(F) when is_function(F) -> + spawn_link(erlang, apply, [F, []]); +spawn_link({M,F}=MF) when is_atom(M), is_atom(F) -> + spawn_link(erlang, apply, [MF, []]); +spawn_link(F) -> + erlang:error(badarg, [F]). + +spawn_link(N, F) when N =:= node() -> + spawn_link(F); +spawn_link(N, F) when is_function(F) -> + spawn_link(N, erlang, apply, [F, []]); +spawn_link(N, {M,F}=MF) when is_atom(M), is_atom(F) -> + spawn_link(N, erlang, apply, [MF, []]); +spawn_link(N, F) -> + erlang:error(badarg, [N, F]). + +%% Spawn and atomically set up a monitor. + +spawn_monitor(F) when is_function(F, 0) -> + erlang:spawn_opt({erlang,apply,[F,[]],[monitor]}); +spawn_monitor(F) -> + erlang:error(badarg, [F]). + +spawn_monitor(M, F, A) when is_atom(M), is_atom(F), is_list(A) -> + erlang:spawn_opt({M,F,A,[monitor]}); +spawn_monitor(M, F, A) -> + erlang:error(badarg, [M,F,A]). + +spawn_opt(F, O) when is_function(F) -> + spawn_opt(erlang, apply, [F, []], O); +spawn_opt({M,F}=MF, O) when is_atom(M), is_atom(F) -> + spawn_opt(erlang, apply, [MF, []], O); +spawn_opt({M,F,A}, O) -> % For (undocumented) backward compatibility + spawn_opt(M, F, A, O); +spawn_opt(F, O) -> + erlang:error(badarg, [F, O]). + +spawn_opt(N, F, O) when N =:= node() -> + spawn_opt(F, O); +spawn_opt(N, F, O) when is_function(F) -> + spawn_opt(N, erlang, apply, [F, []], O); +spawn_opt(N, {M,F}=MF, O) when is_atom(M), is_atom(F) -> + spawn_opt(N, erlang, apply, [MF, []], O); +spawn_opt(N, F, O) -> + erlang:error(badarg, [N, F, O]). + +% Spawns with MFA + +spawn(N,M,F,A) when N =:= node(), is_atom(M), is_atom(F), is_list(A) -> + spawn(M,F,A); +spawn(N,M,F,A) when is_atom(N), is_atom(M), is_atom(F) -> + case is_well_formed_list(A) of + true -> + ok; + false -> + erlang:error(badarg, [N, M, F, A]) + end, + case catch gen_server:call({net_kernel,N}, + {spawn,M,F,A,group_leader()}, + infinity) of + Pid when is_pid(Pid) -> + Pid; + Error -> + case remote_spawn_error(Error, {no_link, N, M, F, A, []}) of + {fault, Fault} -> + erlang:error(Fault, [N, M, F, A]); + Pid -> + Pid + end + end; +spawn(N,M,F,A) -> + erlang:error(badarg, [N, M, F, A]). + +spawn_link(N,M,F,A) when N =:= node(), is_atom(M), is_atom(F), is_list(A) -> + spawn_link(M,F,A); +spawn_link(N,M,F,A) when is_atom(N), is_atom(M), is_atom(F) -> + case is_well_formed_list(A) of + true -> + ok; + _ -> + erlang:error(badarg, [N, M, F, A]) + end, + case catch gen_server:call({net_kernel,N}, + {spawn_link,M,F,A,group_leader()}, + infinity) of + Pid when is_pid(Pid) -> + Pid; + Error -> + case remote_spawn_error(Error, {link, N, M, F, A, []}) of + {fault, Fault} -> + erlang:error(Fault, [N, M, F, A]); + Pid -> + Pid + end + end; +spawn_link(N,M,F,A) -> + erlang:error(badarg, [N, M, F, A]). + +spawn_opt(M, F, A, Opts) -> + case catch erlang:spawn_opt({M,F,A,Opts}) of + {'EXIT',{Reason,_}} -> + erlang:error(Reason, [M,F,A,Opts]); + Res -> + Res + end. + +spawn_opt(N, M, F, A, O) when N =:= node(), + is_atom(M), is_atom(F), is_list(A), + is_list(O) -> + spawn_opt(M, F, A, O); +spawn_opt(N, M, F, A, O) when is_atom(N), is_atom(M), is_atom(F) -> + case {is_well_formed_list(A), is_well_formed_list(O)} of + {true, true} -> + ok; + _ -> + erlang:error(badarg, [N, M, F, A, O]) + end, + case lists:member(monitor, O) of + false -> ok; + true -> erlang:error(badarg, [N, M, F, A, O]) + end, + {L,NO} = lists:foldl(fun (link, {_, NewOpts}) -> + {link, NewOpts}; + (Opt, {LO, NewOpts}) -> + {LO, [Opt|NewOpts]} + end, + {no_link,[]}, + O), + case catch gen_server:call({net_kernel,N}, + {spawn_opt,M,F,A,NO,L,group_leader()}, + infinity) of + Pid when is_pid(Pid) -> + Pid; + Error -> + case remote_spawn_error(Error, {L, N, M, F, A, NO}) of + {fault, Fault} -> + erlang:error(Fault, [N, M, F, A, O]); + Pid -> + Pid + end + end; +spawn_opt(N,M,F,A,O) -> + erlang:error(badarg, [N,M,F,A,O]). + +remote_spawn_error({'EXIT', {{nodedown,N}, _}}, {L, N, M, F, A, O}) -> + {Opts, LL} = case L =:= link of + true -> + {[link|O], [link]}; + false -> + {O, []} + end, + spawn_opt(erlang,crasher,[N,M,F,A,Opts,noconnection], LL); +remote_spawn_error({'EXIT', {Reason, _}}, _) -> + {fault, Reason}; +remote_spawn_error({'EXIT', Reason}, _) -> + {fault, Reason}; +remote_spawn_error(Other, _) -> + {fault, Other}. + +is_well_formed_list([]) -> + true; +is_well_formed_list([_|Rest]) -> + is_well_formed_list(Rest); +is_well_formed_list(_) -> + false. + +crasher(Node,Mod,Fun,Args,[],Reason) -> + error_logger:warning_msg("** Can not start ~w:~w,~w on ~w **~n", + [Mod,Fun,Args,Node]), + exit(Reason); +crasher(Node,Mod,Fun,Args,Opts,Reason) -> + error_logger:warning_msg("** Can not start ~w:~w,~w (~w) on ~w **~n", + [Mod,Fun,Args,Opts,Node]), + exit(Reason). + +yield() -> + erlang:yield(). + +nodes() -> erlang:nodes(visible). + +disconnect_node(Node) -> net_kernel:disconnect(Node). + +fun_info(Fun) when is_function(Fun) -> + Keys = [type,env,arity,name,uniq,index,new_uniq,new_index,module,pid], + fun_info_1(Keys, Fun, []). + +fun_info_1([K|Ks], Fun, A) -> + case erlang:fun_info(Fun, K) of + {K,undefined} -> fun_info_1(Ks, Fun, A); + {K,_}=P -> fun_info_1(Ks, Fun, [P|A]) + end; +fun_info_1([], _, A) -> A. + +-type dst() :: pid() | port() | atom() | {atom(), node()}. + +-spec send_nosuspend(dst(), term()) -> boolean(). +send_nosuspend(Pid, Msg) -> + send_nosuspend(Pid, Msg, []). + +-spec send_nosuspend(dst(), term(), ['noconnect' | 'nosuspend']) -> boolean(). +send_nosuspend(Pid, Msg, Opts) -> + case erlang:send(Pid, Msg, [nosuspend|Opts]) of + ok -> true; + _ -> false + end. + +localtime_to_universaltime(Localtime) -> + erlang:localtime_to_universaltime(Localtime, undefined). + +suspend_process(P) -> + case catch erlang:suspend_process(P, []) of + {'EXIT', {Reason, _}} -> erlang:error(Reason, [P]); + {'EXIT', Reason} -> erlang:error(Reason, [P]); + Res -> Res + end. + +%% +%% If the emulator wants to perform a distributed command and +%% a connection is not established to the actual node the following +%% functions is called in order to set up the connection and then +%% reactivate the command. +%% + +dlink(Pid) -> + case net_kernel:connect(node(Pid)) of + true -> link(Pid); + false -> erlang:dist_exit(self(), noconnection, Pid), true + end. + +%% Can this ever happen? +dunlink(Pid) -> + case net_kernel:connect(node(Pid)) of + true -> unlink(Pid); + false -> true + end. + +dmonitor_node(Node, Flag, []) -> + case net_kernel:connect(Node) of + true -> erlang:monitor_node(Node, Flag, []); + false -> self() ! {nodedown, Node}, true + end; + +dmonitor_node(Node, Flag, Opts) -> + case lists:member(allow_passive_connect,Opts) of + true -> + case net_kernel:passive_cnct(Node) of + true -> erlang:monitor_node(Node, Flag, Opts); + false -> self() ! {nodedown, Node}, true + end; + _ -> + dmonitor_node(Node,Flag,[]) + end. + +dgroup_leader(Leader, Pid) -> + case net_kernel:connect(node(Pid)) of + true -> group_leader(Leader, Pid); + false -> true %% bad arg ? + end. + +dexit(Pid, Reason) -> + case net_kernel:connect(node(Pid)) of + true -> exit(Pid, Reason); + false -> true + end. + +dsend(Pid, Msg) when is_pid(Pid) -> + case net_kernel:connect(node(Pid)) of + true -> erlang:send(Pid, Msg); + false -> Msg + end; +dsend(Port, Msg) when is_port(Port) -> + case net_kernel:connect(node(Port)) of + true -> erlang:send(Port, Msg); + false -> Msg + end; +dsend({Name, Node}, Msg) -> + case net_kernel:connect(Node) of + true -> erlang:send({Name,Node}, Msg); + false -> Msg; + ignored -> Msg % Not distributed. + end. + +dsend(Pid, Msg, Opts) when is_pid(Pid) -> + case net_kernel:connect(node(Pid)) of + true -> erlang:send(Pid, Msg, Opts); + false -> ok + end; +dsend(Port, Msg, Opts) when is_port(Port) -> + case net_kernel:connect(node(Port)) of + true -> erlang:send(Port, Msg, Opts); + false -> ok + end; +dsend({Name, Node}, Msg, Opts) -> + case net_kernel:connect(Node) of + true -> erlang:send({Name,Node}, Msg, Opts); + false -> ok; + ignored -> ok % Not distributed. + end. + +dmonitor_p(process, ProcSpec) -> + %% ProcSpec = pid() | {atom(),atom()} + %% ProcSpec CANNOT be an atom because a locally registered process + %% is never handled here. + + Node = case ProcSpec of + {S,N} when is_atom(S), is_atom(N), N =/= node() -> N; + _ when is_pid(ProcSpec) -> node(ProcSpec) + end, + case net_kernel:connect(Node) of + true -> + erlang:monitor(process, ProcSpec); + false -> + Ref = make_ref(), + self() ! {'DOWN', Ref, process, ProcSpec, noconnection}, + Ref + end. + +%% +%% Trap function used when modified timing has been enabled. +%% + +delay_trap(Result, 0) -> erlang:yield(), Result; +delay_trap(Result, Timeout) -> receive after Timeout -> Result end. + +%% +%% The business with different in and out cookies represented +%% everywhere is discarded. +%% A node has a cookie, connections/messages to that node use that cookie. +%% Messages to us use our cookie. IF we change our cookie, other nodes +%% have to reflect that, which we cannot forsee. +%% +set_cookie(Node, C) when Node =/= nonode@nohost, is_atom(Node) -> + Res = case C of + _ when is_atom(C) -> + auth:set_cookie(Node, C); + {CI,CO} when is_atom(CI), is_atom(CO) -> + auth:set_cookie(Node, {CI, CO}); + _ -> + error + end, + case Res of + error -> exit(badarg); + Other -> Other + end. + +get_cookie() -> + auth:get_cookie(). + +concat_binary(List) -> + list_to_binary(List). + +integer_to_list(I, 10) -> + erlang:integer_to_list(I); +integer_to_list(I, Base) + when is_integer(I), is_integer(Base), Base >= 2, Base =< 1+$Z-$A+10 -> + if I < 0 -> + [$-|integer_to_list(-I, Base, [])]; + true -> + integer_to_list(I, Base, []) + end; +integer_to_list(I, Base) -> + erlang:error(badarg, [I, Base]). + +integer_to_list(I0, Base, R0) -> + D = I0 rem Base, + I1 = I0 div Base, + R1 = if D >= 10 -> + [D-10+$A|R0]; + true -> + [D+$0|R0] + end, + if I1 =:= 0 -> + R1; + true -> + integer_to_list(I1, Base, R1) + end. + + + +list_to_integer(L, 10) -> + erlang:list_to_integer(L); +list_to_integer(L, Base) + when is_list(L), is_integer(Base), Base >= 2, Base =< 1+$Z-$A+10 -> + case list_to_integer_sign(L, Base) of + I when is_integer(I) -> + I; + Fault -> + erlang:error(Fault, [L,Base]) + end; +list_to_integer(L, Base) -> + erlang:error(badarg, [L,Base]). + +list_to_integer_sign([$-|[_|_]=L], Base) -> + case list_to_integer(L, Base, 0) of + I when is_integer(I) -> + -I; + I -> + I + end; +list_to_integer_sign([$+|[_|_]=L], Base) -> + list_to_integer(L, Base, 0); +list_to_integer_sign([_|_]=L, Base) -> + list_to_integer(L, Base, 0); +list_to_integer_sign(_, _) -> + badarg. + +list_to_integer([D|L], Base, I) + when is_integer(D), D >= $0, D =< $9, D < Base+$0 -> + list_to_integer(L, Base, I*Base + D-$0); +list_to_integer([D|L], Base, I) + when is_integer(D), D >= $A, D < Base+$A-10 -> + list_to_integer(L, Base, I*Base + D-$A+10); +list_to_integer([D|L], Base, I) + when is_integer(D), D >= $a, D < Base+$a-10 -> + list_to_integer(L, Base, I*Base + D-$a+10); +list_to_integer([], _, I) -> + I; +list_to_integer(_, _, _) -> + badarg. + +%% erlang:flush_monitor_message/2 is for internal use only! +%% +%% erlang:demonitor(Ref, [flush]) traps to +%% erlang:flush_monitor_message(Ref, Res) when +%% it needs to flush a monitor message. +flush_monitor_message(Ref, Res) when is_reference(Ref), is_atom(Res) -> + receive {_, Ref, _, _, _} -> ok after 0 -> ok end, + Res. + +-record(cpu, {node = -1, + processor = -1, + processor_node = -1, + core = -1, + thread = -1, + logical = -1}). + +%% erlang:set_cpu_topology/1 is for internal use only! +%% +%% erlang:system_flag(cpu_topology, CpuTopology) traps to +%% erlang:set_cpu_topology(CpuTopology). +set_cpu_topology(CpuTopology) -> + try format_cpu_topology(erlang:system_flag(internal_cpu_topology, + cput_e2i(CpuTopology))) + catch + Class:Exception when Class =/= error; Exception =/= internal_error -> + erlang:error(badarg, [CpuTopology]) + end. + +cput_e2i_clvl({logical, _}, _PLvl) -> + #cpu.logical; +cput_e2i_clvl([E | _], PLvl) -> + case element(1, E) of + node -> case PLvl of + 0 -> #cpu.node; + #cpu.processor -> #cpu.processor_node + end; + processor -> case PLvl of + 0 -> #cpu.node; + #cpu.node -> #cpu.processor + end; + core -> #cpu.core; + thread -> #cpu.thread + end. + +cput_e2i(undefined) -> + undefined; +cput_e2i(E) -> + rvrs(cput_e2i(E, -1, -1, #cpu{}, 0, cput_e2i_clvl(E, 0), [])). + +cput_e2i([], _NId, _PId, _IS, _PLvl, _Lvl, Res) -> + Res; +cput_e2i([E|Es], NId0, PId, IS, PLvl, Lvl, Res0) -> + case cput_e2i(E, NId0, PId, IS, PLvl, Lvl, Res0) of + [] -> + cput_e2i(Es, NId0, PId, IS, PLvl, Lvl, Res0); + [#cpu{node = N, + processor = P, + processor_node = PN} = CPU|_] = Res1 -> + NId1 = case N > PN of + true -> N; + false -> PN + end, + cput_e2i(Es, NId1, P, CPU, PLvl, Lvl, Res1) + end; +cput_e2i({Tag, [], TagList}, Nid, PId, CPU, PLvl, Lvl, Res) -> + %% Currently [] is the only valid InfoList + cput_e2i({Tag, TagList}, Nid, PId, CPU, PLvl, Lvl, Res); +cput_e2i({node, NL}, Nid0, PId, _CPU, 0, #cpu.node, Res) -> + Nid1 = Nid0+1, + Lvl = cput_e2i_clvl(NL, #cpu.node), + cput_e2i(NL, Nid1, PId, #cpu{node = Nid1}, #cpu.node, Lvl, Res); +cput_e2i({processor, PL}, Nid, PId0, _CPU, 0, #cpu.node, Res) -> + PId1 = PId0+1, + Lvl = cput_e2i_clvl(PL, #cpu.processor), + cput_e2i(PL, Nid, PId1, #cpu{processor = PId1}, #cpu.processor, Lvl, Res); +cput_e2i({processor, PL}, Nid, PId0, CPU, PLvl, CLvl, Res) + when PLvl < #cpu.processor, CLvl =< #cpu.processor -> + PId1 = PId0+1, + Lvl = cput_e2i_clvl(PL, #cpu.processor), + cput_e2i(PL, Nid, PId1, CPU#cpu{processor = PId1, + processor_node = -1, + core = -1, + thread = -1}, #cpu.processor, Lvl, Res); +cput_e2i({node, NL}, Nid0, PId, CPU, #cpu.processor, #cpu.processor_node, + Res) -> + Nid1 = Nid0+1, + Lvl = cput_e2i_clvl(NL, #cpu.processor_node), + cput_e2i(NL, Nid1, PId, CPU#cpu{processor_node = Nid1}, + #cpu.processor_node, Lvl, Res); +cput_e2i({core, CL}, Nid, PId, #cpu{core = C0} = CPU, PLvl, #cpu.core, Res) + when PLvl < #cpu.core -> + Lvl = cput_e2i_clvl(CL, #cpu.core), + cput_e2i(CL, Nid, PId, CPU#cpu{core = C0+1, thread = -1}, #cpu.core, Lvl, + Res); +cput_e2i({thread, TL}, Nid, PId, #cpu{thread = T0} = CPU, PLvl, #cpu.thread, + Res) when PLvl < #cpu.thread -> + Lvl = cput_e2i_clvl(TL, #cpu.thread), + cput_e2i(TL, Nid, PId, CPU#cpu{thread = T0+1}, #cpu.thread, Lvl, Res); +cput_e2i({logical, ID}, _Nid, PId, #cpu{processor=P, core=C, thread=T} = CPU, + PLvl, #cpu.logical, Res) + when PLvl < #cpu.logical, is_integer(ID), 0 =< ID, ID < 65536 -> + [CPU#cpu{processor = case P of -1 -> PId+1; _ -> P end, + core = case C of -1 -> 0; _ -> C end, + thread = case T of -1 -> 0; _ -> T end, + logical = ID} | Res]. + +%% erlang:format_cpu_topology/1 is for internal use only! +%% +%% erlang:system_info(cpu_topology), +%% and erlang:system_info({cpu_topology, Which}) traps to +%% erlang:format_cpu_topology(InternalCpuTopology). +format_cpu_topology(InternalCpuTopology) -> + try cput_i2e(InternalCpuTopology) + catch _ : _ -> erlang:error(internal_error, [InternalCpuTopology]) + end. + + +cput_i2e(undefined) -> undefined; +cput_i2e(Is) -> cput_i2e(Is, true, #cpu.node, cput_i2e_tag_map()). + +cput_i2e([], _Frst, _Lvl, _TM) -> + []; +cput_i2e([#cpu{logical = LID}| _], _Frst, Lvl, _TM) when Lvl == #cpu.logical -> + {logical, LID}; +cput_i2e([#cpu{} = I | Is], Frst, Lvl, TM) -> + cput_i2e(element(Lvl, I), Frst, Is, [I], Lvl, TM). + +cput_i2e(V, Frst, [I | Is], SameV, Lvl, TM) when V =:= element(Lvl, I) -> + cput_i2e(V, Frst, Is, [I | SameV], Lvl, TM); +cput_i2e(-1, true, [], SameV, Lvl, TM) -> + cput_i2e(rvrs(SameV), true, Lvl+1, TM); +cput_i2e(_V, true, [], SameV, Lvl, TM) when Lvl =/= #cpu.processor, + Lvl =/= #cpu.processor_node -> + cput_i2e(rvrs(SameV), true, Lvl+1, TM); +cput_i2e(-1, _Frst, Is, SameV, #cpu.node, TM) -> + cput_i2e(rvrs(SameV), true, #cpu.processor, TM) + ++ cput_i2e(Is, false, #cpu.node, TM); +cput_i2e(_V, _Frst, Is, SameV, Lvl, TM) -> + [{cput_i2e_tag(Lvl, TM), cput_i2e(rvrs(SameV), true, Lvl+1, TM)} + | cput_i2e(Is, false, Lvl, TM)]. + +cput_i2e_tag_map() -> list_to_tuple([cpu | record_info(fields, cpu)]). + +cput_i2e_tag(Lvl, TM) -> + case element(Lvl, TM) of processor_node -> node; Other -> Other end. + +rvrs([_] = L) -> L; +rvrs(Xs) -> rvrs(Xs, []). + +rvrs([],Ys) -> Ys; +rvrs([X|Xs],Ys) -> rvrs(Xs, [X|Ys]). + +%% erlang:await_proc_exit/3 is for internal use only! +%% +%% BIFs that need to await a specific process exit before +%% returning traps to erlang:await_proc_exit/3. +%% +%% NOTE: This function is tightly coupled to +%% the implementation of the +%% erts_bif_prep_await_proc_exit_*() +%% functions in bif.c. Do not make +%% any changes to it without reading +%% the comment about them in bif.c! +await_proc_exit(Proc, Op, Data) -> + Mon = erlang:monitor(process, Proc), + receive + {'DOWN', Mon, process, _Proc, Reason} -> + case Op of + apply -> + {M, F, A} = Data, + erlang:apply(M, F, A); + data -> + Data; + reason -> + Reason + end + end. + +min(A, B) when A > B -> B; +min(A, _) -> A. + +max(A, B) when A < B -> B; +max(A, _) -> A. diff --git a/erts/preloaded/src/init.erl b/erts/preloaded/src/init.erl new file mode 100644 index 0000000000..c6f4c62f63 --- /dev/null +++ b/erts/preloaded/src/init.erl @@ -0,0 +1,1372 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1996-2009. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% +%% +%% New initial version of init. +%% Booting from a script. The script is fetched either from +%% a local file or distributed from another erlang node. +%% +%% Flags: +%% -id Identity : identity of the system. +%% -boot File : Absolute file name of the boot script. +%% -boot_var Var Value +%% : $Var in the boot script is expanded to +%% Value. +%% -loader LoaderMethod +%% : efile, inet, ose_inet +%% (Optional - default efile) +%% -hosts [Node] : List of hosts from which we can boot. +%% (Mandatory if -loader inet or ose_inet) +%% -mode embedded : Load all modules at startup, no automatic loading +%% -mode interactive : Auto load modules (default system behaviour). +%% -path : Override path in bootfile. +%% -pa Path+ : Add my own paths first. +%% -pz Path+ : Add my own paths last. +%% -run : Start own processes. +%% -s : Start own processes. +%% +%% Experimental flags: +%% -init_debug : Activate debug printouts in init +%% -loader_debug : Activate debug printouts in erl_prim_loader +%% -code_path_choice : strict | relaxed + +-module(init). + +-export([restart/0,reboot/0,stop/0,stop/1, + get_status/0,boot/1,get_arguments/0,get_plain_arguments/0, + get_argument/1,script_id/0]). + +% internal exports +-export([fetch_loaded/0,ensure_loaded/1,make_permanent/2, + notify_when_started/1,wait_until_started/0, + objfile_extension/0, archive_extension/0,code_path_choice/0]). + +-include_lib("kernel/include/file.hrl"). + +-type internal_status() :: 'starting' | 'started' | 'stopping'. + +-record(state, {flags = [], + args = [], + start = [], + kernel = [] :: [{atom(), pid()}], + bootpid :: pid(), + status = {starting, starting} :: {internal_status(), term()}, + script_id = [], + loaded = [], + subscribed = []}). + +-define(ON_LOAD_HANDLER, init__boot__on_load_handler). + +debug(false, _) -> ok; +debug(_, T) -> erlang:display(T). + +-spec get_arguments() -> [{atom(), [string()]}]. +get_arguments() -> + request(get_arguments). + +-spec get_plain_arguments() -> [string()]. +get_plain_arguments() -> + bs2ss(request(get_plain_arguments)). + +-spec get_argument(atom()) -> 'error' | {'ok', [[string()]]}. +get_argument(Arg) -> + request({get_argument, Arg}). + +-spec script_id() -> term(). +script_id() -> + request(script_id). + +bs2as(L0) when is_list(L0) -> + map(fun b2a/1, L0); +bs2as(L) -> + L. + +bs2ss(L0) when is_list(L0) -> + map(fun b2s/1, L0); +bs2ss(L) -> + L. + +-spec get_status() -> {internal_status(), term()}. +get_status() -> + request(get_status). + +-spec fetch_loaded() -> [atom()]. +fetch_loaded() -> + request(fetch_loaded). + +%% Handle dynamic code loading until the +%% real code_server has been started. +-spec ensure_loaded(atom()) -> 'not_allowed' | {'module', atom()}. +ensure_loaded(Module) -> + request({ensure_loaded, Module}). + +make_permanent(Boot,Config) -> + request({make_permanent,Boot,Config}). + +-spec notify_when_started(pid()) -> 'ok' | 'started'. +notify_when_started(Pid) -> + request({notify_when_started,Pid}). + +-spec wait_until_started() -> 'ok'. +wait_until_started() -> + receive + {init,started} -> ok + end. + +request(Req) -> + init ! {self(),Req}, + receive + {init,Rep} -> + Rep + end. + +-spec restart() -> 'ok'. +restart() -> init ! {stop,restart}, ok. + +-spec reboot() -> 'ok'. +reboot() -> init ! {stop,reboot}, ok. + +-spec stop() -> no_return(). +stop() -> init ! {stop,stop}, ok. + +-spec stop(non_neg_integer() | string()) -> no_return(). +stop(Status) -> init ! {stop,{stop,Status}}, ok. + +-spec boot([binary()]) -> no_return(). +boot(BootArgs) -> + register(init, self()), + process_flag(trap_exit, true), + start_on_load_handler_process(), + {Start0,Flags,Args} = parse_boot_args(BootArgs), + Start = map(fun prepare_run_args/1, Start0), + Flags0 = flags_to_atoms_again(Flags), + boot(Start,Flags0,Args). + +prepare_run_args({eval, [Expr]}) -> + {eval,Expr}; +prepare_run_args({_, L=[]}) -> + bs2as(L); +prepare_run_args({_, L=[_]}) -> + bs2as(L); +prepare_run_args({s, [M,F|Args]}) -> + [b2a(M), b2a(F) | bs2as(Args)]; +prepare_run_args({run, [M,F|Args]}) -> + [b2a(M), b2a(F) | bs2ss(Args)]. + +b2a(Bin) when is_binary(Bin) -> + list_to_atom(binary_to_list(Bin)); +b2a(A) when is_atom(A) -> + A. + +b2s(Bin) when is_binary(Bin) -> + binary_to_list(Bin); +b2s(L) when is_list(L) -> + L. + +map(_F, []) -> + []; +map(F, [X|Rest]) -> + [F(X) | map(F, Rest)]. + +flags_to_atoms_again([]) -> + []; +flags_to_atoms_again([{F0,L0}|Rest]) -> + L = L0, + F = b2a(F0), + [{F,L}|flags_to_atoms_again(Rest)]; +flags_to_atoms_again([{F0}|Rest]) -> + F = b2a(F0), + [{F}|flags_to_atoms_again(Rest)]. + +-spec code_path_choice() -> 'relaxed' | 'strict'. +code_path_choice() -> + case get_argument(code_path_choice) of + {ok,[["strict"]]} -> + strict; + {ok,[["relaxed"]]} -> + relaxed; + _Else -> + relaxed + end. + +boot(Start,Flags,Args) -> + BootPid = do_boot(Flags,Start), + State = #state{flags = Flags, + args = Args, + start = Start, + bootpid = BootPid}, + boot_loop(BootPid,State). + +%%% Convert a term to a printable string, if possible. +to_string(X) when is_list(X) -> % assume string + F = flatten(X, []), + case printable_list(F) of + true -> F; + false -> "" + end; +to_string(X) when is_atom(X) -> + atom_to_list(X); +to_string(X) when is_pid(X) -> + pid_to_list(X); +to_string(X) when is_float(X) -> + float_to_list(X); +to_string(X) when is_integer(X) -> + integer_to_list(X); +to_string(_X) -> + "". % can't do anything with it + +%% This is an incorrect and narrow definition of printable characters. +%% The correct one is in io_lib:printable_list/1 +%% +printable_list([H|T]) when is_integer(H), H >= 32, H =< 126 -> + printable_list(T); +printable_list([$\n|T]) -> printable_list(T); +printable_list([$\r|T]) -> printable_list(T); +printable_list([$\t|T]) -> printable_list(T); +printable_list([]) -> true; +printable_list(_) -> false. + +flatten([H|T], Tail) when is_list(H) -> + flatten(H, flatten(T, Tail)); +flatten([H|T], Tail) -> + [H|flatten(T, Tail)]; +flatten([], Tail) -> + Tail. + +things_to_string([X|Rest]) -> + " (" ++ to_string(X) ++ ")" ++ things_to_string(Rest); +things_to_string([]) -> + "". + +halt_string(String, List) -> + HaltString = String ++ things_to_string(List), + if + length(HaltString)<199 -> HaltString; + true -> first198(HaltString, 198) + end. + +first198([H|T], N) when N>0 -> + [H|first198(T, N-1)]; +first198(_, 0) -> + []. + +%% String = string() +%% List = [string() | atom() | pid() | number()] +%% Any other items in List, such as tuples, are ignored when creating +%% the string used as argument to erlang:halt/1. +crash(String, List) -> + halt(halt_string(String, List)). + +%% Status is {InternalStatus,ProvidedStatus} +-spec boot_loop(pid(), #state{}) -> no_return(). +boot_loop(BootPid, State) -> + receive + {BootPid,loaded,ModLoaded} -> + Loaded = State#state.loaded, + boot_loop(BootPid,State#state{loaded = [ModLoaded|Loaded]}); + {BootPid,started,KernelPid} -> + boot_loop(BootPid, new_kernelpid(KernelPid, BootPid, State)); + {BootPid,progress,started} -> + {InS,_} = State#state.status, + notify(State#state.subscribed), + boot_loop(BootPid,State#state{status = {InS,started}, + subscribed = []}); + {BootPid,progress,NewStatus} -> + {InS,_} = State#state.status, + boot_loop(BootPid,State#state{status = {InS,NewStatus}}); + {BootPid,{script_id,Id}} -> + boot_loop(BootPid,State#state{script_id = Id}); + {'EXIT',BootPid,normal} -> + {_,PS} = State#state.status, + notify(State#state.subscribed), + loop(State#state{status = {started,PS}, + subscribed = []}); + {'EXIT',BootPid,Reason} -> + erlang:display({"init terminating in do_boot",Reason}), + crash("init terminating in do_boot", [Reason]); + {'EXIT',Pid,Reason} -> + Kernel = State#state.kernel, + terminate(Pid,Kernel,Reason), %% If Pid is a Kernel pid, halt()! + boot_loop(BootPid,State); + {stop,Reason} -> + stop(Reason,State); + {From,fetch_loaded} -> %% Fetch and reset initially loaded modules. + case whereis(?ON_LOAD_HANDLER) of + undefined -> + %% There is no on_load handler process, + %% probably because init:restart/0 has been + %% called and it is not the first time we + %% pass through here. + ok; + Pid when is_pid(Pid) -> + Pid ! run_on_load, + receive + {'EXIT',Pid,on_load_done} -> + ok; + {'EXIT',Pid,Res} -> + %% Failure to run an on_load handler. + %% This is fatal during start-up. + exit(Res) + end + end, + From ! {init,State#state.loaded}, + garb_boot_loop(BootPid,State#state{loaded = []}); + {From,{ensure_loaded,Module}} -> + {Res, Loaded} = ensure_loaded(Module, State#state.loaded), + From ! {init,Res}, + boot_loop(BootPid,State#state{loaded = Loaded}); + Msg -> + boot_loop(BootPid,handle_msg(Msg,State)) + end. + +ensure_loaded(Module, Loaded) -> + File = concat([Module,objfile_extension()]), + case catch load_mod(Module,File) of + {ok, FullName} -> + {{module, Module}, [{Module, FullName}|Loaded]}; + Res -> + {Res, Loaded} + end. + +%% Tell subscribed processes the system has started. +notify(Pids) -> + lists:foreach(fun(Pid) -> Pid ! {init,started} end, Pids). + +%% Garbage collect all info about initially loaded modules. +%% This information is temporary stored until the code_server +%% is started. +%% We force the garbage collection as the init process holds +%% this information during the initialisation of the system and +%% it will be automatically garbed much later (perhaps not at all +%% if it is not accessed much). + +garb_boot_loop(BootPid,State) -> + garbage_collect(), + boot_loop(BootPid,State). + +new_kernelpid({Name,{ok,Pid}},BootPid,State) when is_pid(Pid) -> + link(Pid), + BootPid ! {self(),ok,Pid}, + Kernel = State#state.kernel, + State#state{kernel = [{Name,Pid}|Kernel]}; +new_kernelpid({_Name,ignore},BootPid,State) -> + BootPid ! {self(),ignore}, + State; +new_kernelpid({Name,What},BootPid,State) -> + erlang:display({"could not start kernel pid",Name,What}), + clear_system(BootPid,State), + crash("could not start kernel pid", [Name, What]). + +%% Here is the main loop after the system has booted. + +loop(State) -> + receive + {'EXIT',Pid,Reason} -> + Kernel = State#state.kernel, + terminate(Pid,Kernel,Reason), %% If Pid is a Kernel pid, halt()! + loop(State); + {stop,Reason} -> + stop(Reason,State); + {From,fetch_loaded} -> %% The Loaded info is cleared in + Loaded = State#state.loaded, %% boot_loop but is handled here + From ! {init,Loaded}, %% anyway. + loop(State); + {From, {ensure_loaded, _}} -> + From ! {init, not_allowed}, + loop(State); + Msg -> + loop(handle_msg(Msg,State)) + end. + +handle_msg(Msg,State0) -> + case catch do_handle_msg(Msg,State0) of + {new_state,State} -> State; + _ -> State0 + end. + +do_handle_msg(Msg,State) -> + #state{flags = Flags, + status = Status, + script_id = Sid, + args = Args, + subscribed = Subscribed} = State, + case Msg of + {From,get_plain_arguments} -> + From ! {init,Args}; + {From,get_arguments} -> + From ! {init,get_arguments(Flags)}; + {From,{get_argument,Arg}} -> + From ! {init,get_argument(Arg,Flags)}; + {From,get_status} -> + From ! {init,Status}; + {From,script_id} -> + From ! {init,Sid}; + {From,{make_permanent,Boot,Config}} -> + {Res,State1} = make_permanent(Boot,Config,Flags,State), + From ! {init,Res}, + {new_state,State1}; + {From,{notify_when_started,Pid}} -> + case Status of + {InS,PS} when InS =:= started ; PS =:= started -> + From ! {init,started}; + _ -> + From ! {init,ok}, + {new_state,State#state{subscribed = [Pid|Subscribed]}} + end; + X -> + case whereis(user) of + undefined -> + catch error_logger ! {info, self(), {self(), X, []}}; + User -> + User ! X, + ok + end + end. + +%%% ------------------------------------------------- +%%% A new release has been installed and made +%%% permanent. +%%% Both restart/0 and reboot/0 shall startup using +%%% the new release. reboot/0 uses new boot script +%%% and configuration file pointed out externally. +%%% In the restart case we have to set new -boot and +%%% -config arguments. +%%% ------------------------------------------------- + +make_permanent(Boot,Config,Flags0,State) -> + case set_flag('-boot',Boot,Flags0) of + {ok,Flags1} -> + case set_flag('-config',Config,Flags1) of + {ok,Flags} -> + {ok,State#state{flags = Flags}}; + Error -> + {Error,State} + end; + Error -> + {Error,State} + end. + +set_flag(_Flag,false,Flags) -> + {ok,Flags}; +set_flag(Flag,Value,Flags) when is_list(Value) -> + case catch list_to_binary(Value) of + {'EXIT',_} -> + {error,badarg}; + AValue -> + {ok,set_argument(Flags,Flag,AValue)} + end; +set_flag(_,_,_) -> + {error,badarg}. + +%%% ------------------------------------------------- +%%% Stop the system. +%%% Reason is: restart | reboot | stop +%%% According to reason terminate emulator or restart +%%% system using the same init process again. +%%% ------------------------------------------------- + +stop(Reason,State) -> + BootPid = State#state.bootpid, + {_,Progress} = State#state.status, + State1 = State#state{status = {stopping, Progress}}, + clear_system(BootPid,State1), + do_stop(Reason,State1). + +do_stop(restart,#state{start = Start, flags = Flags, args = Args}) -> + boot(Start,Flags,Args); +do_stop(reboot,_) -> + halt(); +do_stop(stop,State) -> + stop_heart(State), + halt(); +do_stop({stop,Status},State) -> + stop_heart(State), + halt(Status). + +clear_system(BootPid,State) -> + Heart = get_heart(State#state.kernel), + shutdown_pids(Heart,BootPid,State), + unload(Heart). + +stop_heart(State) -> + case get_heart(State#state.kernel) of + false -> + ok; + Pid -> + %% As heart survives a restart the Parent of heart is init. + BootPid = self(), + %% ignore timeout + shutdown_kernel_pid(Pid, BootPid, self(), State) + end. + +shutdown_pids(Heart,BootPid,State) -> + Timer = shutdown_timer(State#state.flags), + catch shutdown(State#state.kernel,BootPid,Timer,State), + kill_all_pids(Heart), % Even the shutdown timer. + kill_all_ports(Heart), + flush_timout(Timer). + +get_heart([{heart,Pid}|_Kernel]) -> Pid; +get_heart([_|Kernel]) -> get_heart(Kernel); +get_heart(_) -> false. + + +shutdown([{heart,_Pid}|Kernel],BootPid,Timer,State) -> + shutdown(Kernel, BootPid, Timer, State); +shutdown([{_Name,Pid}|Kernel],BootPid,Timer,State) -> + shutdown_kernel_pid(Pid, BootPid, Timer, State), + shutdown(Kernel,BootPid,Timer,State); +shutdown(_,_,_,_) -> + true. + + +%% +%% A kernel pid must handle the special case message +%% {'EXIT',Parent,Reason} and terminate upon it! +%% +shutdown_kernel_pid(Pid, BootPid, Timer, State) -> + Pid ! {'EXIT',BootPid,shutdown}, + shutdown_loop(Pid, Timer, State, []). + +%% +%% We have to handle init requests here in case a process +%% performs such a request and cannot shutdown (deadlock). +%% Keep all other EXIT messages in case it was another +%% kernel process. Resend these messages and handle later. +%% +shutdown_loop(Pid,Timer,State,Exits) -> + receive + {'EXIT',Pid,_} -> + resend(reverse(Exits)), + ok; + {Timer,timeout} -> + erlang:display({init,shutdown_timeout}), + throw(timeout); + {stop,_} -> + shutdown_loop(Pid,Timer,State,Exits); + {From,fetch_loaded} -> + From ! {init,State#state.loaded}, + shutdown_loop(Pid,Timer,State,Exits); + {'EXIT',OtherP,Reason} -> + shutdown_loop(Pid,Timer,State, + [{'EXIT',OtherP,Reason}|Exits]); + Msg -> + State1 = handle_msg(Msg,State), + shutdown_loop(Pid,Timer,State1,Exits) + end. + +resend([ExitMsg|Exits]) -> + self() ! ExitMsg, + resend(Exits); +resend(_) -> + ok. + +%% +%% Kill all existing pids in the system (except init and heart). +kill_all_pids(Heart) -> + case get_pids(Heart) of + [] -> + ok; + Pids -> + kill_em(Pids), + kill_all_pids(Heart) % Continue until all are really killed. + end. + +%% All except zombies. +alive_processes() -> + [P || P <- processes(), erlang:is_process_alive(P)]. + +get_pids(Heart) -> + Pids = alive_processes(), + delete(Heart,self(),Pids). + +delete(Heart,Init,[Heart|Pids]) -> delete(Heart,Init,Pids); +delete(Heart,Init,[Init|Pids]) -> delete(Heart,Init,Pids); +delete(Heart,Init,[Pid|Pids]) -> [Pid|delete(Heart,Init,Pids)]; +delete(_,_,[]) -> []. + +kill_em([Pid|Pids]) -> + exit(Pid,kill), + kill_em(Pids); +kill_em([]) -> + ok. + +%% +%% Kill all existing ports in the system (except the heart port), +%% i.e. ports still existing after all processes have been killed. +%% +%% System ports like the async driver port will nowadays be immortal; +%% therefore, it is ok to send them exit signals... +%% +kill_all_ports(Heart) -> + kill_all_ports(Heart,erlang:ports()). + +kill_all_ports(Heart,[P|Ps]) -> + case erlang:port_info(P,connected) of + {connected,Heart} -> + kill_all_ports(Heart,Ps); + _ -> + exit(P,kill), + kill_all_ports(Heart,Ps) + end; +kill_all_ports(_,_) -> + ok. + +unload(false) -> + do_unload(sub(erlang:pre_loaded(),erlang:loaded())); +unload(_) -> + do_unload(sub([heart|erlang:pre_loaded()],erlang:loaded())). + +do_unload([M|Mods]) -> + catch erlang:purge_module(M), + catch erlang:delete_module(M), + catch erlang:purge_module(M), + do_unload(Mods); +do_unload([]) -> + ok. + +sub([H|T],L) -> sub(T,del(H,L)); +sub([],L) -> L. + +del(Item, [Item|T]) -> T; +del(Item, [H|T]) -> [H|del(Item, T)]; +del(_Item, []) -> []. + +%%% ------------------------------------------------- +%%% If the terminated Pid is one of the processes +%%% added to the Kernel, take down the system brutally. +%%% We are not sure that ANYTHING can work anymore, +%%% i.e. halt the system. +%%% Sleep awhile, it is thus possible for the +%%% error_logger (if it is still alive) to write errors +%%% using the simplest method. +%%% ------------------------------------------------- + +terminate(Pid,Kernel,Reason) -> + case kernel_pid(Pid,Kernel) of + {ok,Name} -> + sleep(500), %% Flush error printouts! + erlang:display({"Kernel pid terminated",Name,Reason}), + crash("Kernel pid terminated", [Name, Reason]); + _ -> + false + end. + +kernel_pid(Pid,[{Name,Pid}|_]) -> + {ok,Name}; +kernel_pid(Pid,[_|T]) -> + kernel_pid(Pid,T); +kernel_pid(_,_) -> + false. + +sleep(T) -> receive after T -> ok end. + +%%% ------------------------------------------------- +%%% Start the loader. +%%% The loader shall run for ever! +%%% ------------------------------------------------- + +start_prim_loader(Init,Id,Pgm,Nodes,Path,{Pa,Pz}) -> + case erl_prim_loader:start(Id,Pgm,Nodes) of + {ok,Pid} when Path =:= false -> + InitPath = append(Pa,["."|Pz]), + erl_prim_loader:set_path(InitPath), + add_to_kernel(Init,Pid), + Pid; + {ok,Pid} -> + erl_prim_loader:set_path(Path), + add_to_kernel(Init,Pid), + Pid; + {error,Reason} -> + erlang:display({"cannot start loader",Reason}), + exit(Reason) + end. + +add_to_kernel(Init,Pid) -> + Init ! {self(),started,{erl_prim_loader,{ok,Pid}}}, + receive + {Init,ok,Pid} -> + unlink(Pid), + ok + end. + +prim_load_flags(Flags) -> + PortPgm = get_flag('-loader',Flags,<<"efile">>), + Hosts = get_flag_list('-hosts', Flags, []), + Id = get_flag('-id',Flags,none), + Path = get_flag_list('-path',Flags,false), + {PortPgm, Hosts, Id, Path}. + +%%% ------------------------------------------------- +%%% The boot process fetches a boot script and loads +%%% all modules specified and starts spec. processes. +%%% Processes specified with -s or -run are finally started. +%%% ------------------------------------------------- + +do_boot(Flags,Start) -> + Self = self(), + spawn_link(fun() -> do_boot(Self,Flags,Start) end). + +do_boot(Init,Flags,Start) -> + process_flag(trap_exit,true), + {Pgm0,Nodes,Id,Path} = prim_load_flags(Flags), + Root = b2s(get_flag('-root',Flags)), + PathFls = path_flags(Flags), + Pgm = b2s(Pgm0), + _Pid = start_prim_loader(Init,b2a(Id),Pgm,bs2as(Nodes), + bs2ss(Path),PathFls), + BootFile = bootfile(Flags,Root), + BootList = get_boot(BootFile,Root), + LoadMode = b2a(get_flag('-mode',Flags,false)), + Deb = b2a(get_flag('-init_debug',Flags,false)), + BootVars = get_flag_args('-boot_var',Flags), + ParallelLoad = + (Pgm =:= "efile") and (erlang:system_info(thread_pool_size) > 0), + + PathChoice = code_path_choice(), + eval_script(BootList,Init,PathFls,{Root,BootVars},Path, + {true,LoadMode,ParallelLoad},Deb,PathChoice), + + %% To help identifying Purify windows that pop up, + %% print the node name into the Purify log. + (catch erlang:system_info({purify, "Node: " ++ atom_to_list(node())})), + + start_em(Start). + +bootfile(Flags,Root) -> + b2s(get_flag('-boot',Flags,concat([Root,"/bin/start"]))). + +path_flags(Flags) -> + Pa = append(reverse(get_flag_args('-pa',Flags))), + Pz = append(get_flag_args('-pz',Flags)), + {bs2ss(Pa),bs2ss(Pz)}. + +get_boot(BootFile0,Root) -> + BootFile = concat([BootFile0,".boot"]), + case get_boot(BootFile) of + {ok, CmdList} -> + CmdList; + not_found -> %% Check for default. + BootF = concat([Root,"/bin/",BootFile]), + case get_boot(BootF) of + {ok, CmdList} -> + CmdList; + not_found -> + exit({'cannot get bootfile',list_to_atom(BootFile)}); + _ -> + exit({'bootfile format error',list_to_atom(BootF)}) + end; + _ -> + exit({'bootfile format error',list_to_atom(BootFile)}) + end. + +get_boot(BootFile) -> + case erl_prim_loader:get_file(BootFile) of + {ok,Bin,_} -> + case binary_to_term(Bin) of + {script,Id,CmdList} when is_list(CmdList) -> + init ! {self(),{script_id,Id}}, % ;-) + {ok, CmdList}; + _ -> + error + end; + _ -> + not_found + end. + +%% +%% Eval a boot script. +%% Load modules and start processes. +%% If a start command does not spawn a new process the +%% boot process hangs (we want to ensure syncronicity). +%% + +eval_script([{progress,Info}|CfgL],Init,PathFs,Vars,P,Ph,Deb,PathChoice) -> + debug(Deb,{progress,Info}), + init ! {self(),progress,Info}, + eval_script(CfgL,Init,PathFs,Vars,P,Ph,Deb,PathChoice); +eval_script([{preLoaded,_}|CfgL],Init,PathFs,Vars,P,Ph,Deb,PathChoice) -> + eval_script(CfgL,Init,PathFs,Vars,P,Ph,Deb,PathChoice); +eval_script([{path,Path}|CfgL],Init,{Pa,Pz},Vars,false,Ph,Deb,PathChoice) -> + RealPath0 = make_path(Pa, Pz, Path, Vars), + RealPath = patch_path(RealPath0, PathChoice), + erl_prim_loader:set_path(RealPath), + eval_script(CfgL,Init,{Pa,Pz},Vars,false,Ph,Deb,PathChoice); +eval_script([{path,_}|CfgL],Init,PathFs,Vars,P,Ph,Deb,PathChoice) -> + %% Ignore, use the command line -path flag. + eval_script(CfgL,Init,PathFs,Vars,P,Ph,Deb,PathChoice); +eval_script([{kernel_load_completed}|CfgL],Init,PathFs,Vars,P,{_,embedded,Par},Deb,PathChoice) -> + eval_script(CfgL,Init,PathFs,Vars,P,{true,embedded,Par},Deb,PathChoice); +eval_script([{kernel_load_completed}|CfgL],Init,PathFs,Vars,P,{_,E,Par},Deb,PathChoice) -> + eval_script(CfgL,Init,PathFs,Vars,P,{false,E,Par},Deb,PathChoice); +eval_script([{primLoad,Mods}|CfgL],Init,PathFs,Vars,P,{true,E,Par},Deb,PathChoice) + when is_list(Mods) -> + if + Par =:= true -> + par_load_modules(Mods,Init); + true -> + load_modules(Mods) + end, + eval_script(CfgL,Init,PathFs,Vars,P,{true,E,Par},Deb,PathChoice); +eval_script([{primLoad,_Mods}|CfgL],Init,PathFs,Vars,P,{false,E,Par},Deb,PathChoice) -> + %% Do not load now, code_server does that dynamically! + eval_script(CfgL,Init,PathFs,Vars,P,{false,E,Par},Deb,PathChoice); +eval_script([{kernelProcess,Server,{Mod,Fun,Args}}|CfgL],Init, + PathFs,Vars,P,Ph,Deb,PathChoice) -> + debug(Deb,{start,Server}), + start_in_kernel(Server,Mod,Fun,Args,Init), + eval_script(CfgL,Init,PathFs,Vars,P,Ph,Deb,PathChoice); +eval_script([{apply,{Mod,Fun,Args}}|CfgL],Init,PathFs,Vars,P,Ph,Deb,PathChoice) -> + debug(Deb,{apply,{Mod,Fun,Args}}), + apply(Mod,Fun,Args), + eval_script(CfgL,Init,PathFs,Vars,P,Ph,Deb,PathChoice); +eval_script([],_,_,_,_,_,_,_) -> + ok; +eval_script(What,_,_,_,_,_,_,_) -> + exit({'unexpected command in bootfile',What}). + +load_modules([Mod|Mods]) -> + File = concat([Mod,objfile_extension()]), + {ok,Full} = load_mod(Mod,File), + init ! {self(),loaded,{Mod,Full}}, %% Tell init about loaded module + load_modules(Mods); +load_modules([]) -> + ok. + +%%% An optimization: erl_prim_loader gets the chance of loading many +%%% files in parallel, using threads. This will reduce the seek times, +%%% and loaded code can be processed while other threads are waiting +%%% for the disk. The optimization is not tried unless the loader is +%%% "efile" and there is a non-empty pool of threads. +%%% +%%% Many threads are needed to get a good result, so it would be +%%% beneficial to load several applications in parallel. However, +%%% measurements show that the file system handles one directory at a +%%% time, regardless if parallel threads are created for files on +%%% several directories (a guess: writing the meta information when +%%% the file was last read ('mtime'), forces the file system to sync +%%% between directories). + +par_load_modules(Mods,Init) -> + Ext = objfile_extension(), + ModFiles = [{Mod,concat([Mod,Ext])} || Mod <- Mods, + not erlang:module_loaded(Mod)], + Self = self(), + Fun = fun(Mod, BinCode, FullName) -> + case catch load_mod_code(Mod, BinCode, FullName) of + {ok, _} -> + Init ! {Self,loaded,{Mod,FullName}}, + ok; + _EXIT -> + {error, Mod} + end + end, + case erl_prim_loader:get_files(ModFiles, Fun) of + ok -> + ok; + {error,Mod} -> + exit({'cannot load',Mod,get_files}) + end. + +make_path(Pa, Pz, Path, Vars) -> + append([Pa,append([fix_path(Path,Vars),Pz])]). + +%% For all Paths starting with $ROOT add rootdir and for those +%% starting with $xxx/, expand $xxx to the value supplied with -boot_var! +%% If $xxx cannot be expanded this process terminates. + +fix_path([Path|Ps], Vars) when is_atom(Path) -> + [add_var(atom_to_list(Path), Vars)|fix_path(Ps, Vars)]; +fix_path([Path|Ps], Vars) -> + [add_var(Path, Vars)|fix_path(Ps, Vars)]; +fix_path(_, _) -> + []. + +add_var("$ROOT/" ++ Path, {Root,_}) -> + concat([Root, "/", Path]); +add_var([$$|Path0], {_,VarList}) -> + {Var,Path} = extract_var(Path0,[]), + Value = b2s(get_var_value(list_to_binary(Var),VarList)), + concat([Value, "/", Path]); +add_var(Path, _) -> + Path. + +extract_var([$/|Path],Var) -> {reverse(Var),Path}; +extract_var([H|T],Var) -> extract_var(T,[H|Var]); +extract_var([],Var) -> {reverse(Var),[]}. + +%% get_var_value(Var, [Vars]) where Vars == [atom()] +get_var_value(Var,[Vars|VarList]) -> + case get_var_val(Var,Vars) of + {ok, Value} -> + Value; + _ -> + get_var_value(Var,VarList) + end; +get_var_value(Var,[]) -> + exit(list_to_atom(concat(["cannot expand \$", Var, " in bootfile"]))). + +get_var_val(Var,[Var,Value|_]) -> {ok, Value}; +get_var_val(Var,[_,_|Vars]) -> get_var_val(Var,Vars); +get_var_val(_,_) -> false. + +patch_path(Dirs, strict) -> + Dirs; +patch_path(Dirs, relaxed) -> + ArchiveExt = archive_extension(), + [patch_dir(Dir, ArchiveExt) || Dir <- Dirs]. + +patch_dir(Orig, ArchiveExt) -> + case funny_split(Orig, $/) of + ["nibe", RevApp, RevArchive | RevTop] -> + App = reverse(RevApp), + case funny_splitwith(RevArchive, $.) of + {Ext, Base} when Ext =:= ArchiveExt, Base =:= App -> + %% Orig archive + Top = reverse([reverse(C) || C <- RevTop]), + Dir = join(Top ++ [App, "ebin"], "/"), + Archive = Orig; + _ -> + %% Orig directory + Top = reverse([reverse(C) || C <- [RevArchive | RevTop]]), + Archive = join(Top ++ [App ++ ArchiveExt, App, "ebin"], "/"), + Dir = Orig + end, + %% First try dir, second try archive and at last use orig if both fails + case erl_prim_loader:read_file_info(Dir) of + {ok, #file_info{type = directory}} -> + Dir; + _ -> + case erl_prim_loader:read_file_info(Archive) of + {ok, #file_info{type = directory}} -> + Archive; + _ -> + Orig + end + end; + _ -> + Orig + end. + +%% Returns all lists in reverse order +funny_split(List, Sep) -> + funny_split(List, Sep, [], []). + +funny_split([Sep | Tail], Sep, Path, Paths) -> + funny_split(Tail, Sep, [], [Path | Paths]); +funny_split([Head | Tail], Sep, Path, Paths) -> + funny_split(Tail, Sep, [Head | Path], Paths); +funny_split([], _Sep, Path, Paths) -> + [Path | Paths]. + +%% Returns {BeforeSep, AfterSep} where BeforeSep is in reverse order +funny_splitwith(List, Sep) -> + funny_splitwith(List, Sep, [], List). + +funny_splitwith([Sep | Tail], Sep, Acc, _Orig) -> + {Acc, Tail}; +funny_splitwith([Head | Tail], Sep, Acc, Orig) -> + funny_splitwith(Tail, Sep, [Head | Acc], Orig); +funny_splitwith([], _Sep, _Acc, Orig) -> + {[], Orig}. + +-spec join([string()], string()) -> string(). +join([H1, H2 | T], S) -> + H1 ++ S ++ join([H2 | T], S); +join([H], _) -> + H. + +%% Servers that are located in the init kernel are linked +%% and supervised by init. + +start_in_kernel(Server,Mod,Fun,Args,Init) -> + Res = apply(Mod,Fun,Args), + Init ! {self(),started,{Server,Res}}, + receive + {Init,ok,Pid} -> + unlink(Pid), %% Just for sure... + ok; + {Init,ignore} -> + ignore + end. + +%% Do start all processes specified at command line using -s! +%% Use apply here instead of spawn to ensure syncronicity for +%% those servers that wish to have it so. +%% Disadvantage: anything started with -s that does not +%% eventually spawn will hang the startup routine. + +%% We also handle -eval here. The argument is an arbitrary +%% expression that should be parsed and evaluated. + +start_em([S|Tail]) -> + case whereis(user) of + undefined -> + ok; + P when is_pid(P) -> %Let's set the group_leader() + erlang:group_leader(P, self()) + end, + start_it(S), + start_em(Tail); +start_em([]) -> ok. + +start_it([]) -> + ok; +start_it({eval,Bin}) -> + Str = binary_to_list(Bin), + {ok,Ts,_} = erl_scan:string(Str), + Ts1 = case reverse(Ts) of + [{dot,_}|_] -> Ts; + TsR -> reverse([{dot,1} | TsR]) + end, + {ok,Expr} = erl_parse:parse_exprs(Ts1), + erl_eval:exprs(Expr, []), + ok; +start_it([_|_]=MFA) -> + Ref = make_ref(), + case catch {Ref,case MFA of + [M] -> M:start(); + [M,F] -> M:F(); + [M,F|Args] -> M:F(Args) % Args is a list + end} of + {Ref,R} -> + R; + {'EXIT',Reason} -> + exit(Reason); + Other -> + throw(Other) + end. + +%% +%% Fetch a module and load it into the system. +%% +load_mod(Mod, File) -> + case erlang:module_loaded(Mod) of + false -> + case erl_prim_loader:get_file(File) of + {ok,BinCode,FullName} -> + load_mod_code(Mod, BinCode, FullName); + _ -> + exit({'cannot load',Mod,get_file}) + end; + _ -> % Already loaded. + {ok,File} + end. + +load_mod_code(Mod, BinCode, FullName) -> + case erlang:module_loaded(Mod) of + false -> + case erlang:load_module(Mod, BinCode) of + {module,Mod} -> {ok,FullName}; + {error,on_load} -> + ?ON_LOAD_HANDLER ! {loaded,Mod}, + {ok,FullName}; + Other -> + exit({'cannot load',Mod,Other}) + end; + _ -> % Already loaded. + {ok,FullName} + end. + +%% -------------------------------------------------------- +%% If -shutdown_time is specified at the command line +%% this timer will inform the init process that it has to +%% force processes to terminate. It cannot be handled +%% softly any longer. +%% -------------------------------------------------------- + +shutdown_timer(Flags) -> + case get_flag('-shutdown_time',Flags,infinity) of + infinity -> + self(); + Time -> + case catch list_to_integer(binary_to_list(Time)) of + T when is_integer(T) -> + Pid = spawn(fun() -> timer(T) end), + receive + {Pid, started} -> + Pid + end; + _ -> + self() + end + end. + +flush_timout(Pid) -> + receive + {Pid, timeout} -> true + after 0 -> true + end. + +timer(T) -> + init ! {self(), started}, + receive + after T -> + init ! {self(), timeout} + end. + +%% -------------------------------------------------------- +%% Parse the command line arguments and extract things to start, flags +%% and other arguments. We keep the relative of the groups. +%% -------------------------------------------------------- + +parse_boot_args(Args) -> + parse_boot_args(Args, [], [], []). + +parse_boot_args([B|Bs], Ss, Fs, As) -> + case check(B) of + start_extra_arg -> + {reverse(Ss),reverse(Fs),lists:reverse(As, Bs)}; % BIF + start_arg -> + {S,Rest} = get_args(Bs, []), + parse_boot_args(Rest, [{s, S}|Ss], Fs, As); + start_arg2 -> + {S,Rest} = get_args(Bs, []), + parse_boot_args(Rest, [{run, S}|Ss], Fs, As); + eval_arg -> + {Expr,Rest} = get_args(Bs, []), + parse_boot_args(Rest, [{eval, Expr}|Ss], Fs, As); + flag -> + {F,Rest} = get_args(Bs, []), + Fl = case F of + [] -> [B]; + FF -> [B,FF] + end, + parse_boot_args(Rest, Ss, + [list_to_tuple(Fl)|Fs], As); + arg -> + parse_boot_args(Bs, Ss, Fs, [B|As]); + end_args -> + parse_boot_args(Bs, Ss, Fs, As) + end; +parse_boot_args([], Start, Flags, Args) -> + {reverse(Start),reverse(Flags),reverse(Args)}. + +check(<<"-extra">>) -> start_extra_arg; +check(<<"-s">>) -> start_arg; +check(<<"-run">>) -> start_arg2; +check(<<"-eval">>) -> eval_arg; +check(<<"--">>) -> end_args; +check(X) when is_binary(X) -> + case binary_to_list(X) of + [$-|_Rest] -> flag; + _Chars -> arg %Even empty atoms + end; +check(_X) -> arg. %This should never occur + +get_args([B|Bs], As) -> + case check(B) of + start_extra_arg -> {reverse(As), [B|Bs]}; + start_arg -> {reverse(As), [B|Bs]}; + start_arg2 -> {reverse(As), [B|Bs]}; + eval_arg -> {reverse(As), [B|Bs]}; + end_args -> {reverse(As), Bs}; + flag -> {reverse(As), [B|Bs]}; + arg -> + get_args(Bs, [B|As]) + end; +get_args([], As) -> {reverse(As),[]}. + +%% +%% Internal get_flag function, with default value. +%% Return: true if flag given without args +%% atom() if a single arg was given. +%% list(atom()) if several args were given. +%% +get_flag(F,Flags,Default) -> + case catch get_flag(F,Flags) of + {'EXIT',_} -> + Default; + Value -> + Value + end. + +get_flag(F,Flags) -> + case search(F,Flags) of + {value,{F,[V]}} -> + V; + {value,{F,V}} -> + V; + {value,{F}} -> % Flag given! + true; + _ -> + exit(list_to_atom(concat(["no ",F," flag"]))) + end. + +%% +%% Internal get_flag function, with default value. +%% Return: list(atom()) +%% +get_flag_list(F,Flags,Default) -> + case catch get_flag_list(F,Flags) of + {'EXIT',_} -> + Default; + Value -> + Value + end. + +get_flag_list(F,Flags) -> + case search(F,Flags) of + {value,{F,V}} -> + V; + _ -> + exit(list_to_atom(concat(["no ",F," flag"]))) + end. + +%% +%% Internal get_flag function. +%% Fetch all occurrences of flag. +%% Return: [Args,Args,...] where Args ::= list(atom()) +%% +get_flag_args(F,Flags) -> get_flag_args(F,Flags,[]). + +get_flag_args(F,[{F,V}|Flags],Acc) when is_list(V) -> + get_flag_args(F,Flags,[V|Acc]); +get_flag_args(F,[{F,V}|Flags],Acc) -> + get_flag_args(F,Flags,[[V]|Acc]); +get_flag_args(F,[_|Flags],Acc) -> + get_flag_args(F,Flags,Acc); +get_flag_args(_,[],Acc) -> + reverse(Acc). + +get_arguments([{F,V}|Flags]) -> + [$-|Fl] = atom_to_list(F), + [{list_to_atom(Fl),to_strings(V)}|get_arguments(Flags)]; +get_arguments([{F}|Flags]) -> + [$-|Fl] = atom_to_list(F), + [{list_to_atom(Fl),[]}|get_arguments(Flags)]; +get_arguments([]) -> + []. + +to_strings([H|T]) when is_atom(H) -> [atom_to_list(H)|to_strings(T)]; +to_strings([H|T]) when is_binary(H) -> [binary_to_list(H)|to_strings(T)]; +to_strings([]) -> []. + +get_argument(Arg,Flags) -> + Args = get_arguments(Flags), + case get_argument1(Arg,Args) of + [] -> + error; + Value -> + {ok,Value} + end. + +get_argument1(Arg,[{Arg,V}|Args]) -> + [V|get_argument1(Arg,Args)]; +get_argument1(Arg,[_|Args]) -> + get_argument1(Arg,Args); +get_argument1(_,[]) -> + []. + +set_argument([{Flag,_}|Flags],Flag,Value) -> + [{Flag,[Value]}|Flags]; +set_argument([{Flag}|Flags],Flag,Value) -> + [{Flag,[Value]}|Flags]; +set_argument([Item|Flags],Flag,Value) -> + [Item|set_argument(Flags,Flag,Value)]; +set_argument([],Flag,Value) -> + [{Flag,[Value]}]. + +concat([A|T]) when is_atom(A) -> + atom_to_list(A) ++ concat(T); +concat([C|T]) when is_integer(C), 0 =< C, C =< 255 -> + [C|concat(T)]; +concat([Bin|T]) when is_binary(Bin) -> + binary_to_list(Bin) ++ concat(T); +concat([S|T]) -> + S ++ concat(T); +concat([]) -> + []. + +append(L, Z) -> L ++ Z. + +append([E]) -> E; +append([H|T]) -> + H ++ append(T); +append([]) -> []. + +reverse([] = L) -> + L; +reverse([_] = L) -> + L; +reverse([A, B]) -> + [B, A]; +reverse([A, B | L]) -> + lists:reverse(L, [B, A]). % BIF + +search(Key, [H|_T]) when is_tuple(H), element(1, H) =:= Key -> + {value, H}; +search(Key, [_|T]) -> + search(Key, T); +search(_Key, []) -> + false. + +-spec objfile_extension() -> nonempty_string(). +objfile_extension() -> + ".beam". +%% case erlang:system_info(machine) of +%% "JAM" -> ".jam"; +%% "VEE" -> ".vee"; +%% "BEAM" -> ".beam" +%% end. + +-spec archive_extension() -> nonempty_string(). +archive_extension() -> + ".ez". + +%%% +%%% Support for handling of on_load functions. +%%% + +start_on_load_handler_process() -> + register(?ON_LOAD_HANDLER, + spawn_link(fun on_load_handler_init/0)). + +on_load_handler_init() -> + on_load_loop([]). + +on_load_loop(Mods) -> + receive + {loaded,Mod} -> + on_load_loop([Mod|Mods]); + run_on_load -> + run_on_load_handlers(Mods), + exit(on_load_done) + end. + +run_on_load_handlers([M|Ms]) -> + Fun = fun() -> + Res = erlang:call_on_load_function(M), + exit(Res) + end, + {Pid,Ref} = spawn_monitor(Fun), + receive + {'DOWN',Ref,process,Pid,OnLoadRes} -> + Keep = if + is_boolean(OnLoadRes) -> OnLoadRes; + true -> false + end, + erlang:finish_after_on_load(M, Keep), + case Keep of + false -> + exit({on_load_function_failed,M}); + true -> + run_on_load_handlers(Ms) + end + end; +run_on_load_handlers([]) -> ok. diff --git a/erts/preloaded/src/otp_ring0.erl b/erts/preloaded/src/otp_ring0.erl new file mode 100644 index 0000000000..3b0d562d1f --- /dev/null +++ b/erts/preloaded/src/otp_ring0.erl @@ -0,0 +1,35 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2000-2009. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% +-module(otp_ring0). + +%% Purpose : Start up of erlang system. + +-export([start/2]). + +start(_Env, Argv) -> + run(init, boot, Argv). + +run(M, F, A) -> + case erlang:function_exported(M, F, 1) of + false -> + erlang:display({fatal,error,module,M,"does not export",F,"/1"}), + halt(1); + true -> + M:F(A) + end. diff --git a/erts/preloaded/src/prim_file.erl b/erts/preloaded/src/prim_file.erl new file mode 100644 index 0000000000..43e6f6cd88 --- /dev/null +++ b/erts/preloaded/src/prim_file.erl @@ -0,0 +1,1168 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2000-2009. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% +-module(prim_file). + +%% Interface module to the file driver. + + + +%%% Interface towards a single file's contents. Uses ?FD_DRV. + +%% Generic file contents operations +-export([open/2, close/1, sync/1, position/2, truncate/1, + write/2, pwrite/2, pwrite/3, read/2, read_line/1, pread/2, pread/3, copy/3]). + +%% Specialized file operations +-export([open/1, open/3]). +-export([read_file/1, read_file/2, write_file/2]). +-export([ipread_s32bu_p32bu/3]). + + + +%%% Interface towards file system and metadata. Uses ?DRV. + +%% Takes an optional port (opens a ?DRV port per default) as first argument. +-export([get_cwd/0, get_cwd/1, get_cwd/2, + set_cwd/1, set_cwd/2, + delete/1, delete/2, + rename/2, rename/3, + make_dir/1, make_dir/2, + del_dir/1, del_dir/2, + read_file_info/1, read_file_info/2, + altname/1, altname/2, + write_file_info/2, write_file_info/3, + make_link/2, make_link/3, + make_symlink/2, make_symlink/3, + read_link/1, read_link/2, + read_link_info/1, read_link_info/2, + list_dir/1, list_dir/2]). +%% How to start and stop the ?DRV port. +-export([start/0, stop/1]). + +%% Debug exports +-export([open_int/4, open_mode/1, open_mode/4]). + +%%%----------------------------------------------------------------- +%%% Includes and defines + +-include("file.hrl"). + +-define(DRV, efile). +-define(FD_DRV, efile). + +-define(LARGEFILESIZE, (1 bsl 63)). + +%% Driver commands +-define(FILE_OPEN, 1). +-define(FILE_READ, 2). +-define(FILE_LSEEK, 3). +-define(FILE_WRITE, 4). +-define(FILE_FSTAT, 5). +-define(FILE_PWD, 6). +-define(FILE_READDIR, 7). +-define(FILE_CHDIR, 8). +-define(FILE_FSYNC, 9). +-define(FILE_MKDIR, 10). +-define(FILE_DELETE, 11). +-define(FILE_RENAME, 12). +-define(FILE_RMDIR, 13). +-define(FILE_TRUNCATE, 14). +-define(FILE_READ_FILE, 15). +-define(FILE_WRITE_INFO, 16). +-define(FILE_LSTAT, 19). +-define(FILE_READLINK, 20). +-define(FILE_LINK, 21). +-define(FILE_SYMLINK, 22). +-define(FILE_CLOSE, 23). +-define(FILE_PWRITEV, 24). +-define(FILE_PREADV, 25). +-define(FILE_SETOPT, 26). +-define(FILE_IPREAD, 27). +-define(FILE_ALTNAME, 28). +-define(FILE_READ_LINE, 29). + +%% Driver responses +-define(FILE_RESP_OK, 0). +-define(FILE_RESP_ERROR, 1). +-define(FILE_RESP_DATA, 2). +-define(FILE_RESP_NUMBER, 3). +-define(FILE_RESP_INFO, 4). +-define(FILE_RESP_NUMERR, 5). +-define(FILE_RESP_LDATA, 6). +-define(FILE_RESP_N2DATA, 7). +-define(FILE_RESP_EOF, 8). + +%% Open modes for the driver's open function. +-define(EFILE_MODE_READ, 1). +-define(EFILE_MODE_WRITE, 2). +-define(EFILE_MODE_READ_WRITE, 3). +-define(EFILE_MODE_APPEND, 4). +-define(EFILE_COMPRESSED, 8). + +%% Use this mask to get just the mode bits to be passed to the driver. +-define(EFILE_MODE_MASK, 15). + +%% Seek modes for the driver's seek function. +-define(EFILE_SEEK_SET, 0). +-define(EFILE_SEEK_CUR, 1). +-define(EFILE_SEEK_END, 2). + +%% Options +-define(FILE_OPT_DELAYED_WRITE, 0). +-define(FILE_OPT_READ_AHEAD, 1). + +%% IPREAD variants +-define(IPREAD_S32BU_P32BU, 0). + + + +%%%----------------------------------------------------------------- +%%% Functions operating on a file through a handle. ?FD_DRV. +%%% +%%% Generic file contents operations. +%%% +%%% Supposed to be called by applications through module file. + + +%% Opens a file using the driver port Port. Returns {error, Reason} +%% | {ok, FileDescriptor} +open(Port, File, ModeList) when is_port(Port), + is_list(File), + is_list(ModeList) -> + case open_mode(ModeList) of + {Mode, _Portopts, _Setopts} -> + open_int(Port, File, Mode, []); + Reason -> + {error, Reason} + end; +open(_,_,_) -> + {error, badarg}. + +%% Opens a file. Returns {error, Reason} | {ok, FileDescriptor}. +open(File, ModeList) when is_list(File), is_list(ModeList) -> + case open_mode(ModeList) of + {Mode, Portopts, Setopts} -> + open_int({?FD_DRV, Portopts}, File, Mode, Setopts); + Reason -> + {error, Reason} + end; +open(_, _) -> + {error, badarg}. + +%% Opens a port that can be used for open/3 or read_file/2. +%% Returns {ok, Port} | {error, Reason}. +open(Portopts) when is_list(Portopts) -> + case drv_open(?FD_DRV, Portopts) of + {error, _} = Error -> + Error; + Other -> + Other + end; +open(_) -> + {error, badarg}. + +open_int({Driver, Portopts}, File, Mode, Setopts) -> + case drv_open(Driver, Portopts) of + {ok, Port} -> + open_int(Port, File, Mode, Setopts); + {error, _} = Error -> + Error + end; +open_int(Port, File, Mode, Setopts) -> + M = Mode band ?EFILE_MODE_MASK, + case drv_command(Port, [<<?FILE_OPEN, M:32>>, File, 0]) of + {ok, Number} -> + open_int_setopts(Port, Number, Setopts); + Error -> + drv_close(Port), + Error + end. + +open_int_setopts(Port, Number, []) -> + {ok, #file_descriptor{module = ?MODULE, data = {Port, Number}}}; +open_int_setopts(Port, Number, [Cmd | Tail]) -> + case drv_command(Port, Cmd) of + ok -> + open_int_setopts(Port, Number, Tail); + Error -> + drv_close(Port), + Error + end. + + + +%% Returns ok. + +close(#file_descriptor{module = ?MODULE, data = {Port, _}}) -> + case drv_command(Port, <<?FILE_CLOSE>>) of + ok -> + drv_close(Port); + Error -> + Error + end; +%% Closes a port opened with open/1. +close(Port) when is_port(Port) -> + drv_close(Port). + + + +%% Returns {error, Reason} | ok. +write(#file_descriptor{module = ?MODULE, data = {Port, _}}, Bytes) -> + case drv_command(Port, [?FILE_WRITE,Bytes]) of + {ok, _Size} -> + ok; + Error -> + Error + end. + +%% Returns ok | {error, {WrittenCount, Reason}} +pwrite(#file_descriptor{module = ?MODULE, data = {Port, _}}, L) + when is_list(L) -> + pwrite_int(Port, L, 0, [], []). + +pwrite_int(_, [], 0, [], []) -> + ok; +pwrite_int(Port, [], N, Spec, Data) -> + Header = list_to_binary([<<?FILE_PWRITEV, N:32>> | reverse(Spec)]), + case drv_command_raw(Port, [Header | reverse(Data)]) of + {ok, _Size} -> + ok; + Error -> + Error + end; +pwrite_int(Port, [{Offs, Bytes} | T], N, Spec, Data) + when is_integer(Offs) -> + if + -(?LARGEFILESIZE) =< Offs, Offs < ?LARGEFILESIZE -> + pwrite_int(Port, T, N, Spec, Data, Offs, Bytes); + true -> + {error, einval} + end; +pwrite_int(_, [_|_], _N, _Spec, _Data) -> + {error, badarg}. + +pwrite_int(Port, T, N, Spec, Data, Offs, Bin) + when is_binary(Bin) -> + Size = byte_size(Bin), + pwrite_int(Port, T, N+1, + [<<Offs:64/signed, Size:64>> | Spec], + [Bin | Data]); +pwrite_int(Port, T, N, Spec, Data, Offs, Bytes) -> + try list_to_binary(Bytes) of + Bin -> + pwrite_int(Port, T, N, Spec, Data, Offs, Bin) + catch + error:Reason -> + {error, Reason} + end. + + + +%% Returns {error, Reason} | ok. +pwrite(#file_descriptor{module = ?MODULE, data = {Port, _}}, Offs, Bytes) + when is_integer(Offs) -> + if + -(?LARGEFILESIZE) =< Offs, Offs < ?LARGEFILESIZE -> + case pwrite_int(Port, [], 0, [], [], Offs, Bytes) of + {error, {_, Reason}} -> + {error, Reason}; + Result -> + Result + end; + true -> + {error, einval} + end; +pwrite(#file_descriptor{module = ?MODULE}, _, _) -> + {error, badarg}. + + + +%% Returns {error, Reason} | ok. +sync(#file_descriptor{module = ?MODULE, data = {Port, _}}) -> + drv_command(Port, [?FILE_FSYNC]). + +%% Returns {ok, Data} | eof | {error, Reason}. +read_line(#file_descriptor{module = ?MODULE, data = {Port, _}}) -> + case drv_command(Port, <<?FILE_READ_LINE>>) of + {ok, {0, _Data}} -> + eof; + {ok, {_Size, Data}} -> + {ok, Data}; + {error, enomem} -> + erlang:garbage_collect(), + case drv_command(Port, <<?FILE_READ_LINE>>) of + {ok, {0, _Data}} -> + eof; + {ok, {_Size, Data}} -> + {ok, Data}; + Other -> + Other + end; + Error -> + Error + end. + +%% Returns {ok, Data} | eof | {error, Reason}. +read(#file_descriptor{module = ?MODULE, data = {Port, _}}, Size) + when is_integer(Size), 0 =< Size -> + if + Size < ?LARGEFILESIZE -> + case drv_command(Port, <<?FILE_READ, Size:64>>) of + {ok, {0, _Data}} when Size =/= 0 -> + eof; + {ok, {_Size, Data}} -> + {ok, Data}; + {error, enomem} -> + %% Garbage collecting here might help if + %% the current processes has some old binaries left. + erlang:garbage_collect(), + case drv_command(Port, <<?FILE_READ, Size:64>>) of + {ok, {0, _Data}} when Size =/= 0 -> + eof; + {ok, {_Size, Data}} -> + {ok, Data}; + Other -> + Other + end; + Error -> + Error + end; + true -> + {error, einval} + end. + +%% Returns {ok, [Data|eof, ...]} | {error, Reason} +pread(#file_descriptor{module = ?MODULE, data = {Port, _}}, L) + when is_list(L) -> + pread_int(Port, L, 0, []). + +pread_int(_, [], 0, []) -> + {ok, []}; +pread_int(Port, [], N, Spec) -> + drv_command(Port, [<<?FILE_PREADV, 0:32, N:32>> | reverse(Spec)]); +pread_int(Port, [{Offs, Size} | T], N, Spec) + when is_integer(Offs), is_integer(Size), 0 =< Size -> + if + -(?LARGEFILESIZE) =< Offs, Offs < ?LARGEFILESIZE, + Size < ?LARGEFILESIZE -> + pread_int(Port, T, N+1, [<<Offs:64/signed, Size:64>> | Spec]); + true -> + {error, einval} + end; +pread_int(_, [_|_], _N, _Spec) -> + {error, badarg}. + + + +%% Returns {ok, Data} | eof | {error, Reason}. +pread(#file_descriptor{module = ?MODULE, data = {Port, _}}, Offs, Size) + when is_integer(Offs), is_integer(Size), 0 =< Size -> + if + -(?LARGEFILESIZE) =< Offs, Offs < ?LARGEFILESIZE, + Size < ?LARGEFILESIZE -> + case drv_command(Port, + <<?FILE_PREADV, 0:32, 1:32, + Offs:64/signed, Size:64>>) of + {ok, [eof]} -> + eof; + {ok, [Data]} -> + {ok, Data}; + Error -> + Error + end; + true -> + {error, einval} + end; +pread(#file_descriptor{module = ?MODULE, data = {_, _}}, _, _) -> + {error, badarg}. + + + +%% Returns {ok, Position} | {error, Reason}. +position(#file_descriptor{module = ?MODULE, data = {Port, _}}, At) -> + case lseek_position(At) of + {Offs, Whence} + when -(?LARGEFILESIZE) =< Offs, Offs < ?LARGEFILESIZE -> + drv_command(Port, <<?FILE_LSEEK, Offs:64/signed, Whence:32>>); + {_, _} -> + {error, einval}; + Reason -> + {error, Reason} + end. + +%% Returns {error, Reaseon} | ok. +truncate(#file_descriptor{module = ?MODULE, data = {Port, _}}) -> + drv_command(Port, <<?FILE_TRUNCATE>>). + + + +%% Returns {error, Reason} | {ok, BytesCopied} +copy(#file_descriptor{module = ?MODULE} = Source, + #file_descriptor{module = ?MODULE} = Dest, + Length) + when is_integer(Length), Length >= 0; + is_atom(Length) -> + %% XXX Should be moved down to the driver for optimization. + file:copy_opened(Source, Dest, Length). + + + +ipread_s32bu_p32bu(#file_descriptor{module = ?MODULE, + data = {_, _}} = Handle, + Offs, + Infinity) when is_atom(Infinity) -> + ipread_s32bu_p32bu(Handle, Offs, (1 bsl 31)-1); +ipread_s32bu_p32bu(#file_descriptor{module = ?MODULE, data = {Port, _}}, + Offs, + MaxSize) + when is_integer(Offs), is_integer(MaxSize) -> + if + -(?LARGEFILESIZE) =< Offs, Offs < ?LARGEFILESIZE, + 0 =< MaxSize, MaxSize < (1 bsl 31) -> + drv_command(Port, <<?FILE_IPREAD, ?IPREAD_S32BU_P32BU, + Offs:64, MaxSize:32>>); + true -> + {error, einval} + end; +ipread_s32bu_p32bu(#file_descriptor{module = ?MODULE, data = {_, _}}, + _Offs, + _MaxSize) -> + {error, badarg}. + + + +%% Returns {ok, Contents} | {error, Reason} +read_file(File) -> + case drv_open(?FD_DRV, [binary]) of + {ok, Port} -> + Result = read_file(Port, File), + close(Port), + Result; + {error, _} = Error -> + Error + end. + +%% Takes a Port opened with open/1. +read_file(Port, File) when is_port(Port) -> + Cmd = [?FILE_READ_FILE | File], + case drv_command(Port, Cmd) of + {error, enomem} -> + %% It could possibly help to do a + %% garbage collection here, + %% if the file server has some references + %% to binaries read earlier. + erlang:garbage_collect(), + drv_command(Port, Cmd); + Result -> + Result + end. + + + +%% Returns {error, Reason} | ok. +write_file(File, Bin) -> + case open(File, [binary, write]) of + {ok, Handle} -> + Result = write(Handle, Bin), + close(Handle), + Result; + Error -> + Error + end. + + + +%%%----------------------------------------------------------------- +%%% Functions operating on files without handle to the file. ?DRV. +%%% +%%% Supposed to be called by applications through module file. + + + +%% Returns {ok, Port}, the Port should be used as first argument in all +%% the following functions. Returns {error, Reason} upon failure. +start() -> + try erlang:open_port({spawn, atom_to_list(?DRV)}, []) of + Port -> + {ok, Port} + catch + error:Reason -> + {error, Reason} + end. + +stop(Port) when is_port(Port) -> + try erlang:port_close(Port) of + _ -> + ok + catch + _:_ -> + ok + end. + + + +%%% The following functions take an optional Port as first argument. +%%% If the port is not supplied, a temporary one is opened and then +%%% closed after the request has been performed. + + + +%% get_cwd/{0,1,2} + +get_cwd() -> + get_cwd_int(0). + +get_cwd(Port) when is_port(Port) -> + get_cwd_int(Port, 0); +get_cwd([]) -> + get_cwd_int(0); +get_cwd([Letter, $: | _]) when $a =< Letter, Letter =< $z -> + get_cwd_int(Letter - $a + 1); +get_cwd([Letter, $: | _]) when $A =< Letter, Letter =< $Z -> + get_cwd_int(Letter - $A + 1); +get_cwd([_|_]) -> + {error, einval}; +get_cwd(_) -> + {error, badarg}. + +get_cwd(Port, []) when is_port(Port) -> + get_cwd_int(Port, 0); +get_cwd(Port, [Letter, $: | _]) + when is_port(Port), $a =< Letter, Letter =< $z -> + get_cwd_int(Port, Letter - $a + 1); +get_cwd(Port, [Letter, $: | _]) + when is_port(Port), $A =< Letter, Letter =< $Z -> + get_cwd_int(Port, Letter - $A + 1); +get_cwd(Port, [_|_]) when is_port(Port) -> + {error, einval}; +get_cwd(_, _) -> + {error, badarg}. + +get_cwd_int(Drive) -> + get_cwd_int({?DRV, []}, Drive). + +get_cwd_int(Port, Drive) -> + drv_command(Port, <<?FILE_PWD, Drive>>). + + + +%% set_cwd/{1,2} + +set_cwd(Dir) -> + set_cwd_int({?DRV, []}, Dir). + +set_cwd(Port, Dir) when is_port(Port) -> + set_cwd_int(Port, Dir). + +set_cwd_int(Port, Dir0) -> + Dir = + (catch + case os:type() of + vxworks -> + %% chdir on vxworks doesn't support + %% relative paths + %% must call get_cwd from here and use + %% absname/2, since + %% absname/1 uses file:get_cwd ... + case get_cwd_int(Port, 0) of + {ok, AbsPath} -> + filename:absname(Dir0, AbsPath); + _Badcwd -> + Dir0 + end; + _Else -> + Dir0 + end), + %% Dir is now either a string or an EXIT tuple. + %% An EXIT tuple will fail in the following catch. + drv_command(Port, [?FILE_CHDIR, Dir, 0]). + + + +%% delete/{1,2} + +delete(File) -> + delete_int({?DRV, []}, File). + +delete(Port, File) when is_port(Port) -> + delete_int(Port, File). + +delete_int(Port, File) -> + drv_command(Port, [?FILE_DELETE, File, 0]). + + + +%% rename/{2,3} + +rename(From, To) -> + rename_int({?DRV, []}, From, To). + +rename(Port, From, To) when is_port(Port) -> + rename_int(Port, From, To). + +rename_int(Port, From, To) -> + drv_command(Port, [?FILE_RENAME, From, 0, To, 0]). + + + +%% make_dir/{1,2} + +make_dir(Dir) -> + make_dir_int({?DRV, []}, Dir). + +make_dir(Port, Dir) when is_port(Port) -> + make_dir_int(Port, Dir). + +make_dir_int(Port, Dir) -> + drv_command(Port, [?FILE_MKDIR, Dir, 0]). + + + +%% del_dir/{1,2} + +del_dir(Dir) -> + del_dir_int({?DRV, []}, Dir). + +del_dir(Port, Dir) when is_port(Port) -> + del_dir_int(Port, Dir). + +del_dir_int(Port, Dir) -> + drv_command(Port, [?FILE_RMDIR, Dir, 0]). + + + +%% read_file_info/{1,2} + +read_file_info(File) -> + read_file_info_int({?DRV, []}, File). + +read_file_info(Port, File) when is_port(Port) -> + read_file_info_int(Port, File). + +read_file_info_int(Port, File) -> + drv_command(Port, [?FILE_FSTAT, File, 0]). + +%% altname/{1,2} + +altname(File) -> + altname_int({?DRV, []}, File). + +altname(Port, File) when is_port(Port) -> + altname_int(Port, File). + +altname_int(Port, File) -> + drv_command(Port, [?FILE_ALTNAME, File, 0]). + + +%% write_file_info/{2,3} + +write_file_info(File, Info) -> + write_file_info_int({?DRV, []}, File, Info). + +write_file_info(Port, File, Info) when is_port(Port) -> + write_file_info_int(Port, File, Info). + +write_file_info_int(Port, + File, + #file_info{mode=Mode, + uid=Uid, + gid=Gid, + atime=Atime0, + mtime=Mtime0, + ctime=Ctime}) -> + {Atime, Mtime} = + case {Atime0, Mtime0} of + {undefined, Mtime0} -> {erlang:localtime(), Mtime0}; + {Atime0, undefined} -> {Atime0, Atime0}; + Complete -> Complete + end, + drv_command(Port, [?FILE_WRITE_INFO, + int_to_bytes(Mode), + int_to_bytes(Uid), + int_to_bytes(Gid), + date_to_bytes(Atime), + date_to_bytes(Mtime), + date_to_bytes(Ctime), + File, 0]). + + + +%% make_link/{2,3} + +make_link(Old, New) -> + make_link_int({?DRV, []}, Old, New). + +make_link(Port, Old, New) when is_port(Port) -> + make_link_int(Port, Old, New). + +make_link_int(Port, Old, New) -> + drv_command(Port, [?FILE_LINK, Old, 0, New, 0]). + + + +%% make_symlink/{2,3} + +make_symlink(Old, New) -> + make_symlink_int({?DRV, []}, Old, New). + +make_symlink(Port, Old, New) when is_port(Port) -> + make_symlink_int(Port, Old, New). + +make_symlink_int(Port, Old, New) -> + drv_command(Port, [?FILE_SYMLINK, Old, 0, New, 0]). + + + +%% read_link/{2,3} + +read_link(Link) -> + read_link_int({?DRV, []}, Link). + +read_link(Port, Link) when is_port(Port) -> + read_link_int(Port, Link). + +read_link_int(Port, Link) -> + drv_command(Port, [?FILE_READLINK, Link, 0]). + + + +%% read_link_info/{2,3} + +read_link_info(Link) -> + read_link_info_int({?DRV, []}, Link). + +read_link_info(Port, Link) when is_port(Port) -> + read_link_info_int(Port, Link). + +read_link_info_int(Port, Link) -> + drv_command(Port, [?FILE_LSTAT, Link, 0]). + + + +%% list_dir/{1,2} + +list_dir(Dir) -> + list_dir_int({?DRV, []}, Dir). + +list_dir(Port, Dir) when is_port(Port) -> + list_dir_int(Port, Dir). + +list_dir_int(Port, Dir) -> + drv_command(Port, [?FILE_READDIR, Dir, 0], []). + + + +%%%----------------------------------------------------------------- +%%% Functions to communicate with the driver + + + +%% Opens a driver port and converts any problems into {error, emfile}. +%% Returns {ok, Port} when succesful. + +drv_open(Driver, Portopts) -> + try erlang:open_port({spawn, Driver}, Portopts) of + Port -> + {ok, Port} + catch + error:Reason -> + {error,Reason} + end. + + + +%% Closes a port in a safe way. Returns ok. + +drv_close(Port) -> + try erlang:port_close(Port) catch error:_ -> ok end, + receive %% Ugly workaround in case the caller==owner traps exits + {'EXIT', Port, _Reason} -> + ok + after 0 -> + ok + end. + + + +%% Issues a command to a port and gets the response. +%% If Port is {Driver, Portopts} a port is first opened and +%% then closed after the result has been received. +%% Returns {ok, Result} or {error, Reason}. + +drv_command_raw(Port, Command) -> + drv_command(Port, Command, false, undefined). + +drv_command(Port, Command) -> + drv_command(Port, Command, undefined). + +drv_command(Port, Command, R) when is_binary(Command) -> + drv_command(Port, Command, true, R); +drv_command(Port, Command, R) -> + try erlang:iolist_to_binary(Command) of + Bin -> + drv_command(Port, Bin, true, R) + catch + error:Reason -> + {error, Reason} + end. + +drv_command(Port, Command, Validated, R) when is_port(Port) -> + try erlang:port_command(Port, Command) of + true -> + drv_get_response(Port, R) + catch + %% If the Command is valid, knowing that the port is a port, + %% a badarg error must mean it is a dead port, that is: + %% a currently invalid filehandle, -> einval, not badarg. + error:badarg when Validated -> + {error, einval}; + error:badarg -> + try erlang:iolist_size(Command) of + _ -> % Valid + {error, einval} + catch + error:_ -> + {error, badarg} + end; + error:Reason -> + {error, Reason} + end; +drv_command({Driver, Portopts}, Command, Validated, R) -> + case drv_open(Driver, Portopts) of + {ok, Port} -> + Result = drv_command(Port, Command, Validated, R), + drv_close(Port), + Result; + Error -> + Error + end. + + + +%% Receives the response from a driver port. +%% Returns: {ok, ListOrBinary}|{error, Reason} + +drv_get_response(Port, R) when is_list(R) -> + case drv_get_response(Port) of + ok -> + {ok, R}; + {ok, Name} -> + drv_get_response(Port, [Name|R]); + Error -> + Error + end; +drv_get_response(Port, _) -> + drv_get_response(Port). + +drv_get_response(Port) -> + erlang:bump_reductions(100), + receive + {Port, {data, [Response|Rest] = Data}} -> + try translate_response(Response, Rest) + catch + error:Reason -> + {error, {bad_response_from_port, Data, + {Reason, erlang:get_stacktrace()}}} + end; + {'EXIT', Port, Reason} -> + {error, {port_died, Reason}} + end. + + +%%%----------------------------------------------------------------- +%%% Utility functions. + + + +%% Converts a list of mode atoms into an mode word for the driver. +%% Returns {Mode, Portopts, Setopts} where Portopts is a list of +%% options for erlang:open_port/2 and Setopts is a list of +%% setopt commands to send to the port, or error Reason upon failure. + +open_mode(List) when is_list(List) -> + case open_mode(List, 0, [], []) of + {Mode, Portopts, Setopts} when Mode band + (?EFILE_MODE_READ bor ?EFILE_MODE_WRITE) + =:= 0 -> + {Mode bor ?EFILE_MODE_READ, Portopts, Setopts}; + Other -> + Other + end. + +open_mode([raw|Rest], Mode, Portopts, Setopts) -> + open_mode(Rest, Mode, Portopts, Setopts); +open_mode([read|Rest], Mode, Portopts, Setopts) -> + open_mode(Rest, Mode bor ?EFILE_MODE_READ, Portopts, Setopts); +open_mode([write|Rest], Mode, Portopts, Setopts) -> + open_mode(Rest, Mode bor ?EFILE_MODE_WRITE, Portopts, Setopts); +open_mode([binary|Rest], Mode, Portopts, Setopts) -> + open_mode(Rest, Mode, [binary | Portopts], Setopts); +open_mode([compressed|Rest], Mode, Portopts, Setopts) -> + open_mode(Rest, Mode bor ?EFILE_COMPRESSED, Portopts, Setopts); +open_mode([append|Rest], Mode, Portopts, Setopts) -> + open_mode(Rest, Mode bor ?EFILE_MODE_APPEND bor ?EFILE_MODE_WRITE, + Portopts, Setopts); +open_mode([delayed_write|Rest], Mode, Portopts, Setopts) -> + open_mode([{delayed_write, 64*1024, 2000}|Rest], Mode, + Portopts, Setopts); +open_mode([{delayed_write, Size, Delay}|Rest], Mode, Portopts, Setopts) + when is_integer(Size), 0 =< Size, is_integer(Delay), 0 =< Delay -> + if + Size < ?LARGEFILESIZE, Delay < 1 bsl 64 -> + open_mode(Rest, Mode, Portopts, + [<<?FILE_SETOPT, ?FILE_OPT_DELAYED_WRITE, + Size:64, Delay:64>> + | Setopts]); + true -> + einval + end; +open_mode([read_ahead|Rest], Mode, Portopts, Setopts) -> + open_mode([{read_ahead, 64*1024}|Rest], Mode, Portopts, Setopts); +open_mode([{read_ahead, Size}|Rest], Mode, Portopts, Setopts) + when is_integer(Size), 0 =< Size -> + if + Size < ?LARGEFILESIZE -> + open_mode(Rest, Mode, Portopts, + [<<?FILE_SETOPT, ?FILE_OPT_READ_AHEAD, + Size:64>> | Setopts]); + true -> + einval + end; +open_mode([], Mode, Portopts, Setopts) -> + {Mode, reverse(Portopts), reverse(Setopts)}; +open_mode(_, _Mode, _Portopts, _Setopts) -> + badarg. + + + +%% Converts a position tuple {bof, X} | {cur, X} | {eof, X} into +%% {Offset, OriginCode} for the driver. +%% Returns badarg upon failure. + +lseek_position(Pos) + when is_integer(Pos) -> + lseek_position({bof, Pos}); +lseek_position(bof) -> + lseek_position({bof, 0}); +lseek_position(cur) -> + lseek_position({cur, 0}); +lseek_position(eof) -> + lseek_position({eof, 0}); +lseek_position({bof, Offset}) + when is_integer(Offset) -> + {Offset, ?EFILE_SEEK_SET}; +lseek_position({cur, Offset}) + when is_integer(Offset) -> + {Offset, ?EFILE_SEEK_CUR}; +lseek_position({eof, Offset}) + when is_integer(Offset) -> + {Offset, ?EFILE_SEEK_END}; +lseek_position(_) -> + badarg. + + + +%% Translates the response from the driver into +%% {ok, Result} or {error, Reason}. + +translate_response(?FILE_RESP_OK, []) -> + ok; +translate_response(?FILE_RESP_OK, Data) -> + {ok, Data}; +translate_response(?FILE_RESP_ERROR, List) when is_list(List) -> + {error, list_to_atom(List)}; +translate_response(?FILE_RESP_NUMBER, List) -> + {N, []} = get_uint64(List), + {ok, N}; +translate_response(?FILE_RESP_DATA, List) -> + {N, Data} = get_uint64(List), + {ok, {N, Data}}; +translate_response(?FILE_RESP_INFO, List) when is_list(List) -> + {ok, transform_info_ints(get_uint32s(List))}; +translate_response(?FILE_RESP_NUMERR, L0) -> + {N, L1} = get_uint64(L0), + {error, {N, list_to_atom(L1)}}; +translate_response(?FILE_RESP_LDATA, List) -> + {ok, transform_ldata(List)}; +translate_response(?FILE_RESP_N2DATA, + <<Offset:64, 0:64, Size:64>>) -> + {ok, {Size, Offset, eof}}; +translate_response(?FILE_RESP_N2DATA, + [<<Offset:64, 0:64, Size:64>> | <<>>]) -> + {ok, {Size, Offset, eof}}; +translate_response(?FILE_RESP_N2DATA = X, + [<<_:64, 0:64, _:64>> | _] = Data) -> + {error, {bad_response_from_port, [X | Data]}}; +translate_response(?FILE_RESP_N2DATA = X, + [<<_:64, _:64, _:64>> | <<>>] = Data) -> + {error, {bad_response_from_port, [X | Data]}}; +translate_response(?FILE_RESP_N2DATA, + [<<Offset:64, _ReadSize:64, Size:64>> | D]) -> + {ok, {Size, Offset, D}}; +translate_response(?FILE_RESP_N2DATA = X, L0) when is_list(L0) -> + {Offset, L1} = get_uint64(L0), + {ReadSize, L2} = get_uint64(L1), + {Size, L3} = get_uint64(L2), + case {ReadSize, L3} of + {0, []} -> + {ok, {Size, Offset, eof}}; + {0, _} -> + {error, {bad_response_from_port, [X | L0]}}; + {_, []} -> + {error, {bad_response_from_port, [X | L0]}}; + _ -> + {ok, {Size, Offset, L3}} + end; +translate_response(?FILE_RESP_EOF, []) -> + eof; +translate_response(X, Data) -> + {error, {bad_response_from_port, [X | Data]}}. + +transform_info_ints(Ints) -> + [HighSize, LowSize, Type|Tail0] = Ints, + Size = HighSize * 16#100000000 + LowSize, + [Ay, Am, Ad, Ah, Ami, As|Tail1] = Tail0, + [My, Mm, Md, Mh, Mmi, Ms|Tail2] = Tail1, + [Cy, Cm, Cd, Ch, Cmi, Cs|Tail3] = Tail2, + [Mode, Links, Major, Minor, Inode, Uid, Gid, Access] = Tail3, + #file_info { + size = Size, + type = file_type(Type), + access = file_access(Access), + atime = {{Ay, Am, Ad}, {Ah, Ami, As}}, + mtime = {{My, Mm, Md}, {Mh, Mmi, Ms}}, + ctime = {{Cy, Cm, Cd}, {Ch, Cmi, Cs}}, + mode = Mode, + links = Links, + major_device = Major, + minor_device = Minor, + inode = Inode, + uid = Uid, + gid = Gid}. + +file_type(1) -> device; +file_type(2) -> directory; +file_type(3) -> regular; +file_type(4) -> symlink; +file_type(_) -> other. + +file_access(0) -> none; +file_access(1) -> write; +file_access(2) -> read; +file_access(3) -> read_write. + +int_to_bytes(Int) when is_integer(Int) -> + <<Int:32>>; +int_to_bytes(undefined) -> + <<-1:32>>. + +date_to_bytes(undefined) -> + <<-1:32, -1:32, -1:32, -1:32, -1:32, -1:32>>; +date_to_bytes({{Y, Mon, D}, {H, Min, S}}) -> + <<Y:32, Mon:32, D:32, H:32, Min:32, S:32>>. + +% uint64([[X1, X2, X3, X4] = Y1 | [X5, X6, X7, X8] = Y2]) -> +% (uint32(Y1) bsl 32) bor uint32(Y2). + +% uint64(X1, X2, X3, X4, X5, X6, X7, X8) -> +% (uint32(X1, X2, X3, X4) bsl 32) bor uint32(X5, X6, X7, X8). + +% uint32([X1,X2,X3,X4]) -> +% (X1 bsl 24) bor (X2 bsl 16) bor (X3 bsl 8) bor X4. + +uint32(X1,X2,X3,X4) -> + (X1 bsl 24) bor (X2 bsl 16) bor (X3 bsl 8) bor X4. + +get_uint64(L0) -> + {X1, L1} = get_uint32(L0), + {X2, L2} = get_uint32(L1), + {(X1 bsl 32) bor X2, L2}. + +get_uint32([X1,X2,X3,X4|List]) -> + {(((((X1 bsl 8) bor X2) bsl 8) bor X3) bsl 8) bor X4, List}. + +get_uint32s([X1,X2,X3,X4|Tail]) -> + [uint32(X1,X2,X3,X4) | get_uint32s(Tail)]; +get_uint32s([]) -> []. + + + +%% Binary mode +transform_ldata(<<0:32, 0:32>>) -> + []; +transform_ldata([<<0:32, N:32, Sizes/binary>> | Datas]) -> + transform_ldata(N, Sizes, Datas, []); +%% List mode +transform_ldata([_,_,_,_,_,_,_,_|_] = L0) -> + {0, L1} = get_uint32(L0), + {N, L2} = get_uint32(L1), + transform_ldata(N, L2, []). + +%% List mode +transform_ldata(0, List, Sizes) -> + transform_ldata(0, List, reverse(Sizes), []); +transform_ldata(N, L0, Sizes) -> + {Size, L1} = get_uint64(L0), + transform_ldata(N-1, L1, [Size | Sizes]). + +%% Binary mode +transform_ldata(1, <<0:64>>, <<>>, R) -> + reverse(R, [eof]); +transform_ldata(1, <<Size:64>>, Data, R) + when byte_size(Data) =:= Size -> + reverse(R, [Data]); +transform_ldata(N, <<0:64, Sizes/binary>>, [<<>> | Datas], R) -> + transform_ldata(N-1, Sizes, Datas, [eof | R]); +transform_ldata(N, <<Size:64, Sizes/binary>>, [Data | Datas], R) + when byte_size(Data) =:= Size -> + transform_ldata(N-1, Sizes, Datas, [Data | R]); +%% List mode +transform_ldata(0, [], [], R) -> + reverse(R); +transform_ldata(0, List, [0 | Sizes], R) -> + transform_ldata(0, List, Sizes, [eof | R]); +transform_ldata(0, List, [Size | Sizes], R) -> + {Front, Rear} = lists_split(List, Size), + transform_ldata(0, Rear, Sizes, [Front | R]). + + + +lists_split(List, 0) when is_list(List) -> + {[], List}; +lists_split(List, N) when is_list(List), is_integer(N), N < 0 -> + erlang:error(badarg, [List, N]); +lists_split(List, N) when is_list(List), is_integer(N) -> + case lists_split(List, N, []) of + premature_end_of_list -> + erlang:error(badarg, [List, N]); + Result -> + Result + end. + +lists_split(List, 0, Rev) -> + {reverse(Rev), List}; +lists_split([], _, _) -> + premature_end_of_list; +lists_split([Hd | Tl], N, Rev) -> + lists_split(Tl, N-1, [Hd | Rev]). + +%% We KNOW that lists:reverse/2 is a BIF. + +reverse(X) -> lists:reverse(X, []). +reverse(L, T) -> lists:reverse(L, T). diff --git a/erts/preloaded/src/prim_inet.erl b/erts/preloaded/src/prim_inet.erl new file mode 100644 index 0000000000..0feb591efb --- /dev/null +++ b/erts/preloaded/src/prim_inet.erl @@ -0,0 +1,1962 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2000-2009. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% +%% The SCTP protocol was added 2006 +%% by Leonid Timochouk <[email protected]> +%% and Serge Aleynikov <[email protected]> +%% at IDT Corp. Adapted by the OTP team at Ericsson AB. +%% +-module(prim_inet). + +%% Primitive inet_drv interface + +-export([open/1, open/2, fdopen/2, fdopen/3, close/1]). +-export([bind/3, listen/1, listen/2]). +-export([connect/3, connect/4, async_connect/4]). +-export([accept/1, accept/2, async_accept/2]). +-export([shutdown/2]). +-export([send/2, send/3, sendto/4, sendmsg/3]). +-export([recv/2, recv/3, async_recv/3]). +-export([unrecv/2]). +-export([recvfrom/2, recvfrom/3]). +-export([setopt/3, setopts/2, getopt/2, getopts/2, is_sockopt_val/2]). +-export([chgopt/3, chgopts/2]). +-export([getstat/2, getfd/1, getindex/1, getstatus/1, gettype/1, + getiflist/1, ifget/3, ifset/3, + gethostname/1]). +-export([getservbyname/3, getservbyport/3]). +-export([peername/1, setpeername/2]). +-export([sockname/1, setsockname/2]). +-export([attach/1, detach/1]). + +-include("inet_sctp.hrl"). +-include("inet_int.hrl"). + +%-define(DEBUG, 1). +-ifdef(DEBUG). +-define(DBG_FORMAT(Format, Args), (io:format((Format), (Args)))). +-else. +-define(DBG_FORMAT(Format, Args), ok). +-endif. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% OPEN(tcp | udp | sctp, inet | inet6) -> +%% {ok, insock()} | +%% {error, Reason} +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +open(Protocol) -> open1(Protocol, ?INET_AF_INET). + +open(Protocol, inet) -> open1(Protocol, ?INET_AF_INET); +open(Protocol, inet6) -> open1(Protocol, ?INET_AF_INET6); +open(_, _) -> {error, einval}. + +fdopen(Protocol, Fd) -> fdopen1(Protocol, ?INET_AF_INET, Fd). + +fdopen(Protocol, Fd, inet) -> fdopen1(Protocol, ?INET_AF_INET, Fd); +fdopen(Protocol, Fd, inet6) -> fdopen1(Protocol, ?INET_AF_INET6, Fd); +fdopen(_, _, _) -> {error, einval}. + +open1(Protocol, Family) -> + case open0(Protocol) of + {ok, S} -> + case ctl_cmd(S, ?INET_REQ_OPEN, [Family]) of + {ok, _} -> + {ok,S}; + Error -> + close(S), Error + end; + Error -> Error + end. + +fdopen1(Protocol, Family, Fd) when is_integer(Fd) -> + case open0(Protocol) of + {ok, S} -> + case ctl_cmd(S,?INET_REQ_FDOPEN,[Family,?int32(Fd)]) of + {ok, _} -> {ok,S}; + Error -> close(S), Error + end; + Error -> Error + end. + +open0(Protocol) -> + try erlang:open_port({spawn_driver,protocol2drv(Protocol)}, [binary]) of + Port -> {ok,Port} + catch + error:Reason -> {error,Reason} + end. + +protocol2drv(tcp) -> "tcp_inet"; +protocol2drv(udp) -> "udp_inet"; +protocol2drv(sctp) -> "sctp_inet"; +protocol2drv(_) -> + erlang:error(eprotonosupport). + +drv2protocol("tcp_inet") -> tcp; +drv2protocol("udp_inet") -> udp; +drv2protocol("sctp_inet") -> sctp; +drv2protocol(_) -> undefined. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% Shutdown(insock(), atom()) -> ok +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% TODO: shutdown equivalent for SCTP +%% +shutdown(S, read) when is_port(S) -> + shutdown_2(S, 0); +shutdown(S, write) when is_port(S) -> + shutdown_1(S, 1); +shutdown(S, read_write) when is_port(S) -> + shutdown_1(S, 2). + +shutdown_1(S, How) -> + case subscribe(S, [subs_empty_out_q]) of + {ok,[{subs_empty_out_q,N}]} when N > 0 -> + shutdown_pend_loop(S, N); %% wait for pending output to be sent + _Other -> ok + end, + shutdown_2(S, How). + +shutdown_2(S, How) -> + case ctl_cmd(S, ?TCP_REQ_SHUTDOWN, [How]) of + {ok, []} -> ok; + Error -> Error + end. + +shutdown_pend_loop(S, N0) -> + receive + {empty_out_q,S} -> ok + after ?INET_CLOSE_TIMEOUT -> + case getstat(S, [send_pend]) of + {ok,[{send_pend,N0}]} -> ok; + {ok,[{send_pend,N}]} -> shutdown_pend_loop(S, N); + _ -> ok + end + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% CLOSE(insock()) -> ok +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +close(S) when is_port(S) -> + unlink(S), %% avoid getting {'EXIT', S, Reason} + case subscribe(S, [subs_empty_out_q]) of + {ok, [{subs_empty_out_q,N}]} when N > 0 -> + close_pend_loop(S, N); %% wait for pending output to be sent + _ -> + catch erlang:port_close(S), + ok + end. + +close_pend_loop(S, N) -> + receive + {empty_out_q,S} -> + catch erlang:port_close(S), ok + after ?INET_CLOSE_TIMEOUT -> + case getstat(S, [send_pend]) of + {ok, [{send_pend,N1}]} -> + if N1 =:= N -> catch erlang:port_close(S), ok; + true -> close_pend_loop(S, N1) + end; + _ -> + catch erlang:port_close(S), ok + end + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% BIND(insock(), IP, Port) -> {ok, integer()} | {error, Reason} +%% +%% bind the insock() to the interface address given by IP and Port +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +bind(S,IP,Port) when is_port(S), is_integer(Port), Port >= 0, Port =< 65535 -> + case ctl_cmd(S,?INET_REQ_BIND,[?int16(Port),ip_to_bytes(IP)]) of + {ok, [P1,P0]} -> {ok, ?u16(P1, P0)}; + Error -> Error + end; + +%% Multi-homed "bind": sctp_bindx(). The Op is 'add' or 'remove'. +%% If no addrs are specified, it just does nothing. +%% Function returns {ok, S} on success, unlike TCP/UDP "bind": +bind(S, Op, Addrs) when is_port(S), is_list(Addrs) -> + case Op of + add -> + bindx(S, 1, Addrs); + remove -> + bindx(S, 0, Addrs); + _ -> {error, einval} + end; +bind(_, _, _) -> {error, einval}. + +bindx(S, AddFlag, Addrs) -> + case getprotocol(S) of + sctp -> + %% Really multi-homed "bindx". Stringified args: + %% [AddFlag, (Port, IP)+]: + Args = ?int8(AddFlag) ++ + lists:concat([?int16(Port)++ip_to_bytes(IP) || + {IP, Port} <- Addrs]), + case ctl_cmd(S, ?SCTP_REQ_BINDX, Args) of + {ok,_} -> {ok, S}; + Error -> Error + end; + _ -> {error, einval} + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% CONNECT(insock(), IP, Port [,Timeout]) -> ok | {error, Reason} +%% +%% connect the insock() to the address given by IP and Port +%% if timeout is given: +%% timeout < 0 -> infinity +%% 0 -> immediate connect (mostly works for loopback) +%% > 0 -> wait for timout ms if not connected then +%% return {error, timeout} +%% +%% ASYNC_CONNECT(insock(), IP, Port, Timeout) -> {ok, S, Ref} | {error, Reason} +%% +%% a {inet_async,S,Ref,Status} will be sent on socket condition +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% For TCP, UDP or SCTP sockets. +%% +connect(S, IP, Port) -> connect0(S, IP, Port, -1). + +connect(S, IP, Port, infinity) -> connect0(S, IP, Port, -1); +connect(S, IP, Port, Time) -> connect0(S, IP, Port, Time). + +connect0(S, IP, Port, Time) when is_port(S), Port > 0, Port =< 65535, + is_integer(Time) -> + case async_connect(S, IP, Port, Time) of + {ok, S, Ref} -> + receive + {inet_async, S, Ref, Status} -> + Status + end; + Error -> Error + end. + +async_connect(S, IP, Port, Time) -> + case ctl_cmd(S, ?INET_REQ_CONNECT, + [enc_time(Time),?int16(Port),ip_to_bytes(IP)]) of + {ok, [R1,R0]} -> {ok, S, ?u16(R1,R0)}; + Error -> Error + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% ACCEPT(insock() [,Timeout] ) -> {ok,insock()} | {error, Reason} +%% +%% accept incoming connection on listen socket +%% if timeout is given: +%% timeout < 0 -> infinity +%% 0 -> immediate accept (poll) +%% > 0 -> wait for timout ms for accept if no accept then +%% return {error, timeout} +%% +%% ASYNC_ACCEPT(insock(), Timeout) +%% +%% async accept. return {ok,S,Ref} or {error, Reason} +%% the owner of socket S will receive an {inet_async,S,Ref,Status} on +%% socket condition +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% For TCP sockets only. +%% +accept(L) -> accept0(L, -1). + +accept(L, infinity) -> accept0(L, -1); +accept(L, Time) -> accept0(L, Time). + +accept0(L, Time) when is_port(L), is_integer(Time) -> + case async_accept(L, Time) of + {ok, Ref} -> + receive + {inet_async, L, Ref, {ok,S}} -> + accept_opts(L, S); + {inet_async, L, Ref, Error} -> + Error + end; + Error -> Error + end. + +%% setup options from listen socket on the connected socket +accept_opts(L, S) -> + case getopts(L, [active, nodelay, keepalive, delay_send, priority, tos]) of + {ok, Opts} -> + case setopts(S, Opts) of + ok -> {ok, S}; + Error -> close(S), Error + end; + Error -> + close(S), Error + end. + +async_accept(L, Time) -> + case ctl_cmd(L,?TCP_REQ_ACCEPT, [enc_time(Time)]) of + {ok, [R1,R0]} -> {ok, ?u16(R1,R0)}; + Error -> Error + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% LISTEN(insock() [,Backlog]) -> ok | {error, Reason} +%% +%% set listen mode on socket +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% For TCP or SCTP sockets. For SCTP, Boolean backlog value (enable/disable +%% listening) is also accepted: + +listen(S) -> listen(S, ?LISTEN_BACKLOG). + +listen(S, BackLog) when is_port(S), is_integer(BackLog) -> + case ctl_cmd(S, ?TCP_REQ_LISTEN, [?int16(BackLog)]) of + {ok, _} -> ok; + Error -> Error + end; +listen(S, Flag) when is_port(S), is_boolean(Flag) -> + case ctl_cmd(S, ?SCTP_REQ_LISTEN, enc_value(set, bool8, Flag)) of + {ok,_} -> ok; + Error -> Error + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% SEND(insock(), Data) -> ok | {error, Reason} +%% +%% send Data on the socket (io-list) +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% This is a generic "port_command" interface used by TCP, UDP, SCTP, depending +%% on the driver it is mapped to, and the "Data". It actually sends out data,-- +%% NOT delegating this task to any back-end. For SCTP, this function MUST NOT +%% be called directly -- use "sendmsg" instead: +%% +send(S, Data, OptList) when is_port(S), is_list(OptList) -> + ?DBG_FORMAT("prim_inet:send(~p, ~p)~n", [S,Data]), + try erlang:port_command(S, Data, OptList) of + false -> % Port busy and nosuspend option passed + ?DBG_FORMAT("prim_inet:send() -> {error,busy}~n", []), + {error,busy}; + true -> + receive + {inet_reply,S,Status} -> + ?DBG_FORMAT("prim_inet:send() -> ~p~n", [Status]), + Status + end + catch + error:_Error -> + ?DBG_FORMAT("prim_inet:send() -> {error,einval}~n", []), + {error,einval} + end. + +send(S, Data) -> + send(S, Data, []). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% SENDTO(insock(), IP, Port, Data) -> ok | {error, Reason} +%% +%% send Datagram to the IP at port (Should add sync send!) +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% "sendto" is for UDP. IP and Port are set by the caller to 0 if the socket +%% is known to be connected. + +sendto(S, IP, Port, Data) when is_port(S), Port >= 0, Port =< 65535 -> + ?DBG_FORMAT("prim_inet:sendto(~p, ~p, ~p, ~p)~n", [S,IP,Port,Data]), + try erlang:port_command(S, [?int16(Port),ip_to_bytes(IP),Data]) of + true -> + receive + {inet_reply,S,Reply} -> + ?DBG_FORMAT("prim_inet:send() -> ~p~n", [Reply]), + Reply + end + catch + error:_ -> + ?DBG_FORMAT("prim_inet:send() -> {error,einval}~n", []), + {error,einval} + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% SENDMSG(insock(), IP, Port, InitMsg, Data) or +%% SENDMSG(insock(), SndRcvInfo, Data) -> ok | {error, Reason} +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% SCTP: Sending data over an existing association: no need for a destination +%% addr; uses SndRcvInfo: +%% +sendmsg(S, #sctp_sndrcvinfo{}=SRI, Data) when is_port(S) -> + Type = type_opt(set, sctp_default_send_param), + try type_value(set, Type, SRI) of + true -> + send(S, [enc_value(set, Type, SRI)|Data]); + false -> {error,einval} + catch + Reason -> {error,Reason} + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% RECV(insock(), Length, [Timeout]) -> {ok,Data} | {error, Reason} +%% +%% receive Length data bytes from a socket +%% if 0 is given then a Data packet is requested (see setopt (packet)) +%% N read N bytes +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% "recv" is for TCP: + +recv(S, Length) -> recv0(S, Length, -1). + +recv(S, Length, infinity) -> recv0(S, Length,-1); + +recv(S, Length, Time) when is_integer(Time) -> recv0(S, Length, Time). + +recv0(S, Length, Time) when is_port(S), is_integer(Length), Length >= 0 -> + case async_recv(S, Length, Time) of + {ok, Ref} -> + receive + {inet_async, S, Ref, Status} -> Status; + {'EXIT', S, _Reason} -> + {error, closed} + end; + Error -> Error + end. + + +async_recv(S, Length, Time) -> + case ctl_cmd(S, ?TCP_REQ_RECV, [enc_time(Time), ?int32(Length)]) of + {ok,[R1,R0]} -> {ok, ?u16(R1,R0)}; + Error -> Error + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% RECVFROM(insock(), Lenth [Timeout]) -> {ok,{IP,Port,Data}} | {error, Reason} +%% For SCTP: -> {ok,{IP,Port,[AncData],Data}} +%% | {error, Reason} +%% receive Length data bytes from a datagram socket sent from IP at Port +%% if 0 is given then a Data packet is requested (see setopt (packet)) +%% N read N bytes +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% "recvfrom" is for both UDP and SCTP. +%% NB: "Length" is actually ignored for these protocols, since they are msg- +%% oriented: preserved here only for API compatibility. +%% +recvfrom(S, Length) -> + recvfrom0(S, Length, -1). + +recvfrom(S, Length, infinity) -> + recvfrom0(S, Length, -1); +recvfrom(S, Length, Time) when is_integer(Time), Time < 16#ffffffff -> + recvfrom0(S, Length, Time); +recvfrom(_, _, _) -> {error,einval}. + +recvfrom0(S, Length, Time) + when is_port(S), is_integer(Length), Length >= 0, Length =< 16#ffffffff -> + case ctl_cmd(S, ?PACKET_REQ_RECV,[enc_time(Time),?int32(Length)]) of + {ok,[R1,R0]} -> + Ref = ?u16(R1,R0), + receive + % Success, UDP: + {inet_async, S, Ref, {ok, [F,P1,P0 | AddrData]}} -> + {IP,Data} = get_ip(F, AddrData), + {ok, {IP, ?u16(P1,P0), Data}}; + + % Success, SCTP: + {inet_async, S, Ref, {ok, {[F,P1,P0 | Addr], AncData, DE}}} -> + {IP, _} = get_ip(F, Addr), + {ok, {IP, ?u16(P1,P0), AncData, DE}}; + + % Back-end error: + {inet_async, S, Ref, Error={error, _}} -> + Error + end; + Error -> + Error % Front-end error + end; +recvfrom0(_, _, _) -> {error,einval}. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% PEERNAME(insock()) -> {ok, {IP, Port}} | {error, Reason} +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +peername(S) when is_port(S) -> + case ctl_cmd(S, ?INET_REQ_PEER, []) of + {ok, [F, P1,P0 | Addr]} -> + {IP, _} = get_ip(F, Addr), + {ok, { IP, ?u16(P1, P0) }}; + Error -> Error + end. + +setpeername(S, {IP,Port}) when is_port(S) -> + case ctl_cmd(S, ?INET_REQ_SETPEER, [?int16(Port),ip_to_bytes(IP)]) of + {ok,[]} -> ok; + Error -> Error + end; +setpeername(S, undefined) when is_port(S) -> + case ctl_cmd(S, ?INET_REQ_SETPEER, []) of + {ok,[]} -> ok; + Error -> Error + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% SOCKNAME(insock()) -> {ok, {IP, Port}} | {error, Reason} +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +sockname(S) when is_port(S) -> + case ctl_cmd(S, ?INET_REQ_NAME, []) of + {ok, [F, P1, P0 | Addr]} -> + {IP, _} = get_ip(F, Addr), + {ok, { IP, ?u16(P1, P0) }}; + Error -> Error + end. + +setsockname(S, {IP,Port}) when is_port(S) -> + case ctl_cmd(S, ?INET_REQ_SETNAME, [?int16(Port),ip_to_bytes(IP)]) of + {ok,[]} -> ok; + Error -> Error + end; +setsockname(S, undefined) when is_port(S) -> + case ctl_cmd(S, ?INET_REQ_SETNAME, []) of + {ok,[]} -> ok; + Error -> Error + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% SETOPT(insock(), Opt, Value) -> ok | {error, Reason} +%% SETOPTS(insock(), [{Opt,Value}]) -> ok | {error, Reason} +%% +%% set socket, ip and driver option +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +setopt(S, Opt, Value) when is_port(S) -> + setopts(S, [{Opt,Value}]). + +setopts(S, Opts) when is_port(S) -> + case encode_opt_val(Opts) of + {ok, Buf} -> + case ctl_cmd(S, ?INET_REQ_SETOPTS, Buf) of + {ok, _} -> ok; + Error -> Error + end; + Error -> Error + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% GETOPT(insock(), Opt) -> {ok,Value} | {error, Reason} +%% GETOPTS(insock(), [Opt]) -> {ok, [{Opt,Value}]} | {error, Reason} +%% get socket, ip and driver option +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +getopt(S, Opt) when is_port(S), is_atom(Opt) -> + case getopts(S, [Opt]) of + {ok,[{_,Value}]} -> {ok, Value}; + Error -> Error + end. + +getopts(S, Opts) when is_port(S), is_list(Opts) -> + case encode_opts(Opts) of + {ok,Buf} -> + case ctl_cmd(S, ?INET_REQ_GETOPTS, Buf) of + {ok,Rep} -> + %% Non-SCTP: "Rep" contains the encoded option vals: + decode_opt_val(Rep); + {error,sctp_reply} -> + %% SCTP: Need to receive the full value: + receive + {inet_reply,S,Res} -> Res + end; + Error -> Error + end; + Error -> Error + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% CHGOPT(insock(), Opt) -> {ok,Value} | {error, Reason} +%% CHGOPTS(insock(), [Opt]) -> {ok, [{Opt,Value}]} | {error, Reason} +%% change socket, ip and driver option +%% +%% Same as setopts except for record value options where undefined +%% fields are read with getopts before setting. +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +chgopt(S, Opt, Value) when is_port(S) -> + chgopts(S, [{Opt,Value}]). + +chgopts(S, Opts) when is_port(S), is_list(Opts) -> + case inet:getopts(S, need_template(Opts)) of + {ok,Templates} -> + try merge_options(Opts, Templates) of + NewOpts -> + setopts(S, NewOpts) + catch + Reason -> {error,Reason} + end; + Error -> Error + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% IFLIST(insock()) -> {ok,IfNameList} | {error, Reason} +%% +%% get interface name list +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +getiflist(S) when is_port(S) -> + case ctl_cmd(S, ?INET_REQ_GETIFLIST, []) of + {ok, Data} -> {ok, build_iflist(Data)}; + Error -> Error + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% ifget(insock(), IFOpts) -> {ok,IfNameList} | {error, Reason} +%% +%% get interface name list +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +ifget(S, Name, Opts) -> + case encode_ifname(Name) of + {ok, Buf1} -> + case encode_ifopts(Opts,[]) of + {ok, Buf2} -> + case ctl_cmd(S, ?INET_REQ_IFGET, [Buf1,Buf2]) of + {ok, Data} -> decode_ifopts(Data,[]); + Error -> Error + end; + Error -> Error + end; + Error -> Error + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% ifset(insock(), Name, IFOptVals) -> {ok,IfNameList} | {error, Reason} +%% +%% set interface parameters +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +ifset(S, Name, Opts) -> + case encode_ifname(Name) of + {ok, Buf1} -> + case encode_ifopt_val(Opts,[]) of + {ok, Buf2} -> + case ctl_cmd(S, ?INET_REQ_IFSET, [Buf1,Buf2]) of + {ok, _} -> ok; + Error -> Error + end; + Error -> Error + end; + Error -> Error + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% subscribe(insock(), SubsList) -> {ok,StatReply} | {error, Reason} +%% +%% Subscribe on socket events (from driver) +%% +%% Available event subscriptions: +%% subs_empty_out_q: StatReply = [{subs_empty_out_q, N}], where N +%% is current queue length. When the queue becomes empty +%% a {empty_out_q, insock()} message will be sent to +%% subscribing process and the subscription will be +%% removed. If N = 0, the queue is empty and no +%% subscription is made. +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +subscribe(S, Sub) when is_port(S), is_list(Sub) -> + case encode_subs(Sub) of + {ok, Bytes} -> + case ctl_cmd(S, ?INET_REQ_SUBSCRIBE, Bytes) of + {ok, Data} -> decode_subs(Data); + Error -> Error + end; + Error -> Error + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% GETSTAT(insock(), StatList) -> {ok,StatReply} | {error, Reason} +%% +%% get socket statistics (from driver) +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +getstat(S, Stats) when is_port(S), is_list(Stats) -> + case encode_stats(Stats) of + {ok, Bytes} -> + case ctl_cmd(S, ?INET_REQ_GETSTAT, Bytes) of + {ok, Data} -> decode_stats(Data); + Error -> Error + end; + Error -> Error + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% GETFD(insock()) -> {ok,integer()} | {error, Reason} +%% +%% get internal file descriptor +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +getfd(S) when is_port(S) -> + case ctl_cmd(S, ?INET_REQ_GETFD, []) of + {ok, [S3,S2,S1,S0]} -> {ok, ?u32(S3,S2,S1,S0)}; + Error -> Error + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% GETIX(insock()) -> {ok,integer()} | {error, Reason} +%% +%% get internal socket index +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +getindex(S) when is_port(S) -> + %% NOT USED ANY MORE + {error, einval}. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% GETTYPE(insock()) -> {ok,{Family,Type}} | {error, Reason} +%% +%% get family/type of a socket +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +gettype(S) when is_port(S) -> + case ctl_cmd(S, ?INET_REQ_GETTYPE, []) of + {ok, [F3,F2,F1,F0,T3,T2,T1,T0]} -> + Family = case ?u32(F3,F2,F1,F0) of + ?INET_AF_INET -> inet; + ?INET_AF_INET6 -> inet6; + _ -> undefined + end, + Type = case ?u32(T3,T2,T1,T0) of + ?INET_TYPE_STREAM -> stream; + ?INET_TYPE_DGRAM -> dgram; + ?INET_TYPE_SEQPACKET -> seqpacket; + _ -> undefined + end, + {ok, {Family, Type}}; + Error -> Error + end. + +getprotocol(S) when is_port(S) -> + {name,Drv} = erlang:port_info(S, name), + drv2protocol(Drv). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% IS_SCTP(insock()) -> true | false +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% is_sctp(S) when is_port(S) -> +%% case gettype(S) of +%% {ok, {_, seqpacket}} -> true; +%% _ -> false +%% end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% GETSTATUS(insock()) -> {ok,Status} | {error, Reason} +%% +%% get socket status +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +getstatus(S) when is_port(S) -> + case ctl_cmd(S, ?INET_REQ_GETSTATUS, []) of + {ok, [S3,S2,S1,S0]} -> + {ok, dec_status(?u32(S3,S2,S1,S0))}; + Error -> Error + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% GETHOSTNAME(insock()) -> {ok,HostName} | {error, Reason} +%% +%% get host name +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +gethostname(S) when is_port(S) -> + ctl_cmd(S, ?INET_REQ_GETHOSTNAME, []). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% GETSERVBYNAME(insock(),Name,Proto) -> {ok,Port} | {error, Reason} +%% +%% get service port +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +getservbyname(S,Name,Proto) when is_port(S), is_atom(Name), is_atom(Proto) -> + getservbyname1(S, atom_to_list(Name), atom_to_list(Proto)); +getservbyname(S,Name,Proto) when is_port(S), is_atom(Name), is_list(Proto) -> + getservbyname1(S, atom_to_list(Name), Proto); +getservbyname(S,Name,Proto) when is_port(S), is_list(Name), is_atom(Proto) -> + getservbyname1(S, Name, atom_to_list(Proto)); +getservbyname(S,Name,Proto) when is_port(S), is_list(Name), is_list(Proto) -> + getservbyname1(S, Name, Proto); +getservbyname(_,_, _) -> + {error, einval}. + +getservbyname1(S,Name,Proto) -> + L1 = length(Name), + L2 = length(Proto), + if L1 > 255 -> {error, einval}; + L2 > 255 -> {error, einval}; + true -> + case ctl_cmd(S, ?INET_REQ_GETSERVBYNAME, [L1,Name,L2,Proto]) of + {ok, [P1,P0]} -> + {ok, ?u16(P1,P0)}; + Error -> + Error + end + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% GETSERVBYPORT(insock(),Port,Proto) -> {ok,Port} | {error, Reason} +%% +%% get service port from portnumber and protocol +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +getservbyport(S,Port,Proto) when is_port(S), is_atom(Proto) -> + getservbyport1(S, Port, atom_to_list(Proto)); +getservbyport(S,Port,Proto) when is_port(S), is_list(Proto) -> + getservbyport1(S, Port, Proto); +getservbyport(_, _, _) -> + {error, einval}. + +getservbyport1(S,Port,Proto) -> + L = length(Proto), + if Port < 0 -> {error, einval}; + Port > 16#ffff -> {error, einval}; + L > 255 -> {error, einval}; + true -> + case ctl_cmd(S, ?INET_REQ_GETSERVBYPORT, [?int16(Port),L,Proto]) of + {ok, Name} -> {ok, Name}; + Error -> Error + end + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% UNRECV(insock(), data) -> ok | {error, Reason} +%% +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +unrecv(S, Data) -> + case ctl_cmd(S, ?TCP_REQ_UNRECV, Data) of + {ok, _} -> ok; + Error -> Error + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% DETACH(insock()) -> ok +%% +%% unlink from a socket +%% +%% ATTACH(insock()) -> ok | {error, Reason} +%% +%% link and connect to a socket +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +detach(S) when is_port(S) -> + unlink(S), + ok. + +attach(S) when is_port(S) -> + try erlang:port_connect(S, self()) of + true -> link(S), ok + catch + error:Reason -> {error,Reason} + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% INTERNAL FUNCTIONS +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +is_sockopt_val(Opt, Val) -> + Type = type_opt(set, Opt), + try type_value(set, Type, Val) + catch + _ -> false + end. + +%% +%% Socket options processing: Encoding option NAMES: +%% +enc_opt(reuseaddr) -> ?INET_OPT_REUSEADDR; +enc_opt(keepalive) -> ?INET_OPT_KEEPALIVE; +enc_opt(dontroute) -> ?INET_OPT_DONTROUTE; +enc_opt(linger) -> ?INET_OPT_LINGER; +enc_opt(broadcast) -> ?INET_OPT_BROADCAST; +enc_opt(sndbuf) -> ?INET_OPT_SNDBUF; +enc_opt(recbuf) -> ?INET_OPT_RCVBUF; +enc_opt(priority) -> ?INET_OPT_PRIORITY; +enc_opt(tos) -> ?INET_OPT_TOS; +enc_opt(nodelay) -> ?TCP_OPT_NODELAY; +enc_opt(multicast_if) -> ?UDP_OPT_MULTICAST_IF; +enc_opt(multicast_ttl) -> ?UDP_OPT_MULTICAST_TTL; +enc_opt(multicast_loop) -> ?UDP_OPT_MULTICAST_LOOP; +enc_opt(add_membership) -> ?UDP_OPT_ADD_MEMBERSHIP; +enc_opt(drop_membership) -> ?UDP_OPT_DROP_MEMBERSHIP; +enc_opt(buffer) -> ?INET_LOPT_BUFFER; +enc_opt(header) -> ?INET_LOPT_HEADER; +enc_opt(active) -> ?INET_LOPT_ACTIVE; +enc_opt(packet) -> ?INET_LOPT_PACKET; +enc_opt(mode) -> ?INET_LOPT_MODE; +enc_opt(deliver) -> ?INET_LOPT_DELIVER; +enc_opt(exit_on_close) -> ?INET_LOPT_EXITONCLOSE; +enc_opt(high_watermark) -> ?INET_LOPT_TCP_HIWTRMRK; +enc_opt(low_watermark) -> ?INET_LOPT_TCP_LOWTRMRK; +enc_opt(bit8) -> ?INET_LOPT_BIT8; +enc_opt(send_timeout) -> ?INET_LOPT_TCP_SEND_TIMEOUT; +enc_opt(send_timeout_close) -> ?INET_LOPT_TCP_SEND_TIMEOUT_CLOSE; +enc_opt(delay_send) -> ?INET_LOPT_TCP_DELAY_SEND; +enc_opt(packet_size) -> ?INET_LOPT_PACKET_SIZE; +enc_opt(read_packets) -> ?INET_LOPT_READ_PACKETS; +enc_opt(raw) -> ?INET_OPT_RAW; +% Names of SCTP opts: +enc_opt(sctp_rtoinfo) -> ?SCTP_OPT_RTOINFO; +enc_opt(sctp_associnfo) -> ?SCTP_OPT_ASSOCINFO; +enc_opt(sctp_initmsg) -> ?SCTP_OPT_INITMSG; +enc_opt(sctp_autoclose) -> ?SCTP_OPT_AUTOCLOSE; +enc_opt(sctp_nodelay) -> ?SCTP_OPT_NODELAY; +enc_opt(sctp_disable_fragments) -> ?SCTP_OPT_DISABLE_FRAGMENTS; +enc_opt(sctp_i_want_mapped_v4_addr)-> ?SCTP_OPT_I_WANT_MAPPED_V4_ADDR; +enc_opt(sctp_maxseg) -> ?SCTP_OPT_MAXSEG; +enc_opt(sctp_set_peer_primary_addr)-> ?SCTP_OPT_SET_PEER_PRIMARY_ADDR; +enc_opt(sctp_primary_addr) -> ?SCTP_OPT_PRIMARY_ADDR; +enc_opt(sctp_adaptation_layer) -> ?SCTP_OPT_ADAPTATION_LAYER; +enc_opt(sctp_peer_addr_params) -> ?SCTP_OPT_PEER_ADDR_PARAMS; +enc_opt(sctp_default_send_param) -> ?SCTP_OPT_DEFAULT_SEND_PARAM; +enc_opt(sctp_events) -> ?SCTP_OPT_EVENTS; +enc_opt(sctp_delayed_ack_time) -> ?SCTP_OPT_DELAYED_ACK_TIME; +enc_opt(sctp_status) -> ?SCTP_OPT_STATUS; +enc_opt(sctp_get_peer_addr_info) -> ?SCTP_OPT_GET_PEER_ADDR_INFO. +%% + +%% +%% Decoding option NAMES: +%% +dec_opt(?INET_OPT_REUSEADDR) -> reuseaddr; +dec_opt(?INET_OPT_KEEPALIVE) -> keepalive; +dec_opt(?INET_OPT_DONTROUTE) -> dontroute; +dec_opt(?INET_OPT_LINGER) -> linger; +dec_opt(?INET_OPT_BROADCAST) -> broadcast; +dec_opt(?INET_OPT_SNDBUF) -> sndbuf; +dec_opt(?INET_OPT_RCVBUF) -> recbuf; +dec_opt(?INET_OPT_PRIORITY) -> priority; +dec_opt(?INET_OPT_TOS) -> tos; +dec_opt(?TCP_OPT_NODELAY) -> nodelay; +dec_opt(?UDP_OPT_MULTICAST_IF) -> multicast_if; +dec_opt(?UDP_OPT_MULTICAST_TTL) -> multicast_ttl; +dec_opt(?UDP_OPT_MULTICAST_LOOP) -> multicast_loop; +dec_opt(?UDP_OPT_ADD_MEMBERSHIP) -> add_membership; +dec_opt(?UDP_OPT_DROP_MEMBERSHIP) -> drop_membership; +dec_opt(?INET_LOPT_BUFFER) -> buffer; +dec_opt(?INET_LOPT_HEADER) -> header; +dec_opt(?INET_LOPT_ACTIVE) -> active; +dec_opt(?INET_LOPT_PACKET) -> packet; +dec_opt(?INET_LOPT_MODE) -> mode; +dec_opt(?INET_LOPT_DELIVER) -> deliver; +dec_opt(?INET_LOPT_EXITONCLOSE) -> exit_on_close; +dec_opt(?INET_LOPT_TCP_HIWTRMRK) -> high_watermark; +dec_opt(?INET_LOPT_TCP_LOWTRMRK) -> low_watermark; +dec_opt(?INET_LOPT_BIT8) -> bit8; +dec_opt(?INET_LOPT_TCP_SEND_TIMEOUT) -> send_timeout; +dec_opt(?INET_LOPT_TCP_SEND_TIMEOUT_CLOSE) -> send_timeout_close; +dec_opt(?INET_LOPT_TCP_DELAY_SEND) -> delay_send; +dec_opt(?INET_LOPT_PACKET_SIZE) -> packet_size; +dec_opt(?INET_LOPT_READ_PACKETS) -> read_packets; +dec_opt(?INET_OPT_RAW) -> raw; +dec_opt(I) when is_integer(I) -> undefined. + + + +%% Metatypes: +%% [] Value must be 'undefined' or nonexistent +%% for setopts and getopts. +%% [Type] Value required for setopts and getopts, +%% will be encoded for both. +%% [Type,Default] Default used if value is 'undefined'. +%% [[Type,Default]] A combination of the two above. +%% Type Value must be 'undefined' or nonexistent for getops, +%% required for setopts. +%% +%% The use of [] and [[Type,Default]] is commented out in enc_value/2 +%% and type_value/2 below since they are only used in record fields. +%% And record fields does not call enc_value/2 nor type_value/2. +%% Anyone introducing these metatypes otherwhere will have to activate +%% those clauses in enc_value/2 and type_value/2. You have been warned! + +type_opt(get, raw) -> [{[int],[int],[binary_or_uint]}]; +type_opt(_, raw) -> {int,int,binary}; +%% NB: "sctp_status" and "sctp_get_peer_addr_info" are read-only options, +%% so they should not be NOT encoded for use with "setopt". +type_opt(get, sctp_status) -> + [{record,#sctp_status{ + assoc_id = [sctp_assoc_id], + _ = []}}]; +type_opt(get, sctp_get_peer_addr_info) -> + [{record,#sctp_paddrinfo{ + assoc_id = [[sctp_assoc_id,0]], + address = [[addr,{any,0}]], + _ = []}}]; +type_opt(_, Opt) -> + type_opt_1(Opt). + +%% Types of option values, by option name: +%% +type_opt_1(reuseaddr) -> bool; +type_opt_1(keepalive) -> bool; +type_opt_1(dontroute) -> bool; +type_opt_1(linger) -> {bool,int}; +type_opt_1(broadcast) -> bool; +type_opt_1(sndbuf) -> int; +type_opt_1(recbuf) -> int; +type_opt_1(priority) -> int; +type_opt_1(tos) -> int; +type_opt_1(nodelay) -> bool; +%% multicast +type_opt_1(multicast_ttl) -> int; +type_opt_1(multicast_loop) -> bool; +type_opt_1(multicast_if) -> ip; +type_opt_1(add_membership) -> {ip,ip}; +type_opt_1(drop_membership) -> {ip,ip}; +%% driver options +type_opt_1(header) -> uint; +type_opt_1(buffer) -> int; +type_opt_1(active) -> + {enum,[{false, ?INET_PASSIVE}, + {true, ?INET_ACTIVE}, + {once, ?INET_ONCE}]}; +type_opt_1(packet) -> + {enum,[{0, ?TCP_PB_RAW}, + {1, ?TCP_PB_1}, + {2, ?TCP_PB_2}, + {4, ?TCP_PB_4}, + {raw,?TCP_PB_RAW}, + {sunrm, ?TCP_PB_RM}, + {asn1, ?TCP_PB_ASN1}, + {cdr, ?TCP_PB_CDR}, + {fcgi, ?TCP_PB_FCGI}, + {line, ?TCP_PB_LINE_LF}, + {tpkt, ?TCP_PB_TPKT}, + {http, ?TCP_PB_HTTP}, + {httph,?TCP_PB_HTTPH}, + {http_bin, ?TCP_PB_HTTP_BIN}, + {httph_bin,?TCP_PB_HTTPH_BIN}, + {ssl, ?TCP_PB_SSL_TLS}, % obsolete + {ssl_tls, ?TCP_PB_SSL_TLS}]}; +type_opt_1(mode) -> + {enum,[{list, ?INET_MODE_LIST}, + {binary, ?INET_MODE_BINARY}]}; +type_opt_1(deliver) -> + {enum,[{port, ?INET_DELIVER_PORT}, + {term, ?INET_DELIVER_TERM}]}; +type_opt_1(exit_on_close) -> bool; +type_opt_1(low_watermark) -> int; +type_opt_1(high_watermark) -> int; +type_opt_1(bit8) -> + {enum,[{clear, ?INET_BIT8_CLEAR}, + {set, ?INET_BIT8_SET}, + {on, ?INET_BIT8_ON}, + {off, ?INET_BIT8_OFF}]}; +type_opt_1(send_timeout) -> time; +type_opt_1(send_timeout_close) -> bool; +type_opt_1(delay_send) -> bool; +type_opt_1(packet_size) -> uint; +type_opt_1(read_packets) -> uint; +%% +%% SCTP options (to be set). If the type is a record type, the corresponding +%% record signature is returned, otherwise, an "elementary" type tag +%% is returned: +%% +%% for SCTP_OPT_RTOINFO +type_opt_1(sctp_rtoinfo) -> + [{record,#sctp_rtoinfo{ + assoc_id = [[sctp_assoc_id,0]], + initial = [uint32,0], + max = [uint32,0], + min = [uint32,0]}}]; +%% for SCTP_OPT_ASSOCINFO +type_opt_1(sctp_associnfo) -> + [{record,#sctp_assocparams{ + assoc_id = [[sctp_assoc_id,0]], + asocmaxrxt = [uint16,0], + number_peer_destinations = [uint16,0], + peer_rwnd = [uint32,0], + local_rwnd = [uint32,0], + cookie_life = [uint32,0]}}]; +%% for SCTP_OPT_INITMSG and SCTP_TAG_SEND_ANC_INITMSG (send*) +type_opt_1(sctp_initmsg) -> + [{record,#sctp_initmsg{ + num_ostreams = [uint16,0], + max_instreams = [uint16,0], + max_attempts = [uint16,0], + max_init_timeo = [uint16,0]}}]; +%% +type_opt_1(sctp_nodelay) -> bool; +type_opt_1(sctp_autoclose) -> uint; +type_opt_1(sctp_disable_fragments) -> bool; +type_opt_1(sctp_i_want_mapped_v4_addr) -> bool; +type_opt_1(sctp_maxseg) -> uint; +%% for SCTP_OPT_PRIMARY_ADDR +type_opt_1(sctp_primary_addr) -> + [{record,#sctp_prim{ + assoc_id = [sctp_assoc_id], + addr = addr}}]; +%% for SCTP_OPT_SET_PEER_PRIMARY_ADDR +type_opt_1(sctp_set_peer_primary_addr) -> + [{record,#sctp_setpeerprim{ + assoc_id = [sctp_assoc_id], + addr = addr}}]; +%% for SCTP_OPT_ADAPTATION_LAYER +type_opt_1(sctp_adaptation_layer) -> + [{record,#sctp_setadaptation{ + adaptation_ind = [uint32,0]}}]; +%% for SCTP_OPT_PEER_ADDR_PARAMS +type_opt_1(sctp_peer_addr_params) -> + [{record,#sctp_paddrparams{ + assoc_id = [[sctp_assoc_id,0]], + address = [[addr,{any,0}]], + hbinterval = [uint32,0], + pathmaxrxt = [uint16,0], + pathmtu = [uint32,0], + sackdelay = [uint32,0], + flags = + [{bitenumlist, + [{hb_enable, ?SCTP_FLAG_HB_ENABLE}, + {hb_disable, ?SCTP_FLAG_HB_DISABLE}, + {hb_demand, ?SCTP_FLAG_HB_DEMAND}, + {pmtud_enable, ?SCTP_FLAG_PMTUD_ENABLE}, + {pmtud_disable, ?SCTP_FLAG_PMTUD_DISABLE}, + {sackdelay_enable, ?SCTP_FLAG_SACKDELAY_ENABLE}, + {sackdelay_disable, ?SCTP_FLAG_SACKDELAY_DISABLE}], + uint32},[]]}}]; +%% for SCTP_OPT_DEFAULT_SEND_PARAM and SCTP_TAG_SEND_ANC_PARAMS (on send*) +type_opt_1(sctp_default_send_param) -> + [{record,#sctp_sndrcvinfo{ + stream = [uint16,0], + ssn = [], + flags = + [{bitenumlist, + [{unordered, ?SCTP_FLAG_UNORDERED}, + {addr_over, ?SCTP_FLAG_ADDR_OVER}, + {abort, ?SCTP_FLAG_ABORT}, + {eof, ?SCTP_FLAG_EOF}], + uint16},[]], + ppid = [uint32,0], + context = [uint32,0], + timetolive = [uint32,0], + tsn = [], + cumtsn = [], + assoc_id = [sctp_assoc_id,0]}}]; +%% for SCTP_OPT_EVENTS +type_opt_1(sctp_events) -> + [{record,#sctp_event_subscribe{ + data_io_event = [bool8,true], + association_event = [bool8,true], + address_event = [bool8,true], + send_failure_event = [bool8,true], + peer_error_event = [bool8,true], + shutdown_event = [bool8,true], + partial_delivery_event = [bool8,true], + adaptation_layer_event = [bool8,false], + authentication_event = [bool8,false]}}]; +%% for SCTP_OPT_DELAYED_ACK_TIME +type_opt_1(sctp_delayed_ack_time) -> + [{record,#sctp_assoc_value{ + assoc_id = [[sctp_assoc_id,0]], + assoc_value = [uint32,0]}}]; +%% +type_opt_1(undefined) -> undefined; +type_opt_1(O) when is_atom(O) -> undefined. + + + +%% Get. No supplied value. +type_value(get, undefined) -> false; % Undefined type +%% These two clauses can not happen since they are only used +%% in record fields - from record fields they must have a +%% value though it might be 'undefined', so record fields +%% calls type_value/3, not type_value/2. +%% type_value(get, []) -> true; % Ignored +%% type_value(get, [[Type,Default]]) -> % Required field, default value +%% type_value(get, Type, Default); +type_value(get, [{record,Types}]) -> % Implied default value for record + type_value_record(get, Types, + erlang:make_tuple(tuple_size(Types), undefined), 2); +type_value(get, [_]) -> false; % Required value missing +type_value(get, _) -> true. % Field is supposed to be undefined + +%% Get and set. Value supplied. +type_value(_, undefined, _) -> false; % Undefined type +type_value(_, [], undefined) -> true; % Ignored +type_value(_, [], _) -> false; % Value should not be supplied +type_value(Q, [Type], Value) -> % Required field, proceed + type_value_default(Q, Type, Value); +type_value(set, Type, Value) -> % Required for setopts + type_value_default(set, Type, Value); +type_value(_, _, undefined) -> true; % Value should be undefined for +type_value(_, _, _) -> false. % other than setopts. + +type_value_default(Q, [Type,Default], undefined) -> + type_value_1(Q, Type, Default); +type_value_default(Q, [Type,_], Value) -> + type_value_1(Q, Type, Value); +type_value_default(Q, Type, Value) -> + type_value_1(Q, Type, Value). + +type_value_1(Q, {record,Types}, undefined) -> + type_value_record(Q, Types, + erlang:make_tuple(tuple_size(Types), undefined), 2); +type_value_1(Q, {record,Types}, Values) + when tuple_size(Types) =:= tuple_size(Values) -> + type_value_record(Q, Types, Values, 2); +type_value_1(Q, Types, Values) + when tuple_size(Types) =:= tuple_size(Values) -> + type_value_tuple(Q, Types, Values, 1); +type_value_1(_, Type, Value) -> + type_value_2(Type, Value). + +type_value_tuple(Q, Types, Values, N) + when is_integer(N), N =< tuple_size(Types) -> + type_value(Q, element(N, Types), element(N, Values)) + andalso type_value_tuple(Q, Types, Values, N+1); +type_value_tuple(_, _, _, _) -> true. + +type_value_record(Q, Types, Values, N) + when is_integer(N), N =< tuple_size(Types) -> + case type_value(Q, element(N, Types), element(N, Values)) of + true -> type_value_record(Q, Types, Values, N+1); + false -> + erlang:throw({type,{record,Q,Types,Values,N}}) + end; +type_value_record(_, _, _, _) -> true. + +%% Simple run-time type-checking of (option) values: type -vs- value: +%% NB: the LHS is the TYPE, not the option name! +%% +%% Returns true | false | throw(ErrorReason) only for record types +%% +type_value_2(undefined, _) -> false; +%% +type_value_2(bool, true) -> true; +type_value_2(bool, false) -> true; +type_value_2(bool8, true) -> true; +type_value_2(bool8, false) -> true; +type_value_2(int, X) when is_integer(X) -> true; +type_value_2(uint, X) when is_integer(X), X >= 0 -> true; +type_value_2(uint32, X) when X band 16#ffffffff =:= X -> true; +type_value_2(uint24, X) when X band 16#ffffff =:= X -> true; +type_value_2(uint16, X) when X band 16#ffff =:= X -> true; +type_value_2(uint8, X) when X band 16#ff =:= X -> true; +type_value_2(time, infinity) -> true; +type_value_2(time, X) when is_integer(X), X >= 0 -> true; +type_value_2(ip,{A,B,C,D}) when ?ip(A,B,C,D) -> true; +type_value_2(addr, {any,Port}) -> + type_value_2(uint16, Port); +type_value_2(addr, {loopback,Port}) -> + type_value_2(uint16, Port); +type_value_2(addr, {{A,B,C,D},Port}) when ?ip(A,B,C,D) -> + type_value_2(uint16, Port); +type_value_2(addr, {{A,B,C,D,E,F,G,H},Port}) when ?ip6(A,B,C,D,E,F,G,H) -> + type_value_2(uint16, Port); +type_value_2(ether,[X1,X2,X3,X4,X5,X6]) + when ?ether(X1,X2,X3,X4,X5,X6) -> true; +type_value_2({enum,List}, Enum) -> + case enum_val(Enum, List) of + {value,_} -> true; + false -> false + end; +type_value_2({bitenumlist,List}, EnumList) -> + case enum_vals(EnumList, List) of + Ls when is_list(Ls) -> true; + false -> false + end; +type_value_2({bitenumlist,List,_}, EnumList) -> + case enum_vals(EnumList, List) of + Ls when is_list(Ls) -> true; + false -> false + end; +type_value_2(binary,Bin) when is_binary(Bin) -> true; +type_value_2(binary_or_uint,Bin) when is_binary(Bin) -> true; +type_value_2(binary_or_uint,Int) when is_integer(Int), Int >= 0 -> true; +%% Type-checking of SCTP options +type_value_2(sctp_assoc_id, X) + when X band 16#ffffffff =:= X -> true; +type_value_2(_, _) -> false. + + + +%% Get. No supplied value. +%% +%% These two clauses can not happen since they are only used +%% in record fields - from record fields they must have a +%% value though it might be 'undefined', so record fields +%% calls enc_value/3, not enc_value/2. +%% enc_value(get, []) -> []; % Ignored +%% enc_value(get, [[Type,Default]]) -> % Required field, default value +%% enc_value(get, Type, Default); +enc_value(get, [{record,Types}]) -> % Implied default value for record + enc_value_tuple(get, Types, + erlang:make_tuple(tuple_size(Types), undefined), 2); +enc_value(get, _) -> []. + +%% Get and set +enc_value(_, [], _) -> []; % Ignored +enc_value(Q, [Type], Value) -> % Required field, proceed + enc_value_default(Q, Type, Value); +enc_value(set, Type, Value) -> % Required for setopts + enc_value_default(set, Type, Value); +enc_value(_, _, _) -> []. % Not encoded for other than setopts + +enc_value_default(Q, [Type,Default], undefined) -> + enc_value_1(Q, Type, Default); +enc_value_default(Q, [Type,_], Value) -> + enc_value_1(Q, Type, Value); +enc_value_default(Q, Type, Value) -> + enc_value_1(Q, Type, Value). + +enc_value_1(Q, {record,Types}, undefined) -> + enc_value_tuple(Q, Types, + erlang:make_tuple(tuple_size(Types), undefined), 2); +enc_value_1(Q, {record,Types}, Values) + when tuple_size(Types) =:= tuple_size(Values) -> + enc_value_tuple(Q, Types, Values, 2); +enc_value_1(Q, Types, Values) when tuple_size(Types) =:= tuple_size(Values) -> + enc_value_tuple(Q, Types, Values, 1); +enc_value_1(_, Type, Value) -> + enc_value_2(Type, Value). + +enc_value_tuple(Q, Types, Values, N) + when is_integer(N), N =< tuple_size(Types) -> + [enc_value(Q, element(N, Types), element(N, Values)) + |enc_value_tuple(Q, Types, Values, N+1)]; +enc_value_tuple(_, _, _, _) -> []. + +%% +%% Encoding of option VALUES: +%% +enc_value_2(bool, true) -> [0,0,0,1]; +enc_value_2(bool, false) -> [0,0,0,0]; +enc_value_2(bool8, true) -> [1]; +enc_value_2(bool8, false) -> [0]; +enc_value_2(int, Val) -> ?int32(Val); +enc_value_2(uint, Val) -> ?int32(Val); +enc_value_2(uint32, Val) -> ?int32(Val); +enc_value_2(uint24, Val) -> ?int24(Val); +enc_value_2(uint16, Val) -> ?int16(Val); +enc_value_2(uint8, Val) -> ?int8(Val); +enc_value_2(time, infinity) -> ?int32(-1); +enc_value_2(time, Val) -> ?int32(Val); +enc_value_2(ip,{A,B,C,D}) -> [A,B,C,D]; +enc_value_2(ip, any) -> [0,0,0,0]; +enc_value_2(ip, loopback) -> [127,0,0,1]; +enc_value_2(addr, {any,Port}) -> + [?INET_AF_ANY|?int16(Port)]; +enc_value_2(addr, {loopback,Port}) -> + [?INET_AF_LOOPBACK|?int16(Port)]; +enc_value_2(addr, {IP,Port}) -> + case tuple_size(IP) of + 4 -> + [?INET_AF_INET,?int16(Port)|ip4_to_bytes(IP)]; + 8 -> + [?INET_AF_INET6,?int16(Port)|ip6_to_bytes(IP)] + end; +enc_value_2(ether, [X1,X2,X3,X4,X5,X6]) -> [X1,X2,X3,X4,X5,X6]; +enc_value_2(sctp_assoc_id, Val) -> ?int32(Val); +%% enc_value_2(sctp_assoc_id, Bin) -> [byte_size(Bin),Bin]; +enc_value_2({enum,List}, Enum) -> + {value,Val} = enum_val(Enum, List), + ?int32(Val); +enc_value_2({bitenumlist,List}, EnumList) -> + Vs = enum_vals(EnumList, List), + Val = borlist(Vs, 0), + ?int32(Val); +enc_value_2({bitenumlist,List,Type}, EnumList) -> + Vs = enum_vals(EnumList, List), + Value = borlist(Vs, 0), + enc_value_2(Type, Value); +enc_value_2(binary,Bin) -> [?int32(byte_size(Bin)),Bin]; +enc_value_2(binary_or_uint,Datum) when is_binary(Datum) -> + [1,enc_value_2(binary, Datum)]; +enc_value_2(binary_or_uint,Datum) when is_integer(Datum) -> + [0,enc_value_2(uint, Datum)]. + + + +%% +%% Decoding of option VALUES receved from "getopt": +%% NOT required for SCTP, as it always returns ready terms, not lists: +%% +dec_value(bool, [0,0,0,0|T]) -> {false,T}; +dec_value(bool, [_,_,_,_|T]) -> {true,T}; +%% Currently not used i.e only used by SCTP that does not dec_value/2 +%% dec_value(bool8, [0|T]) -> {false,T}; +%% dec_value(bool8, [_|T]) -> {true,T}; +dec_value(int, [X3,X2,X1,X0|T]) -> {?i32(X3,X2,X1,X0),T}; +dec_value(uint, [X3,X2,X1,X0|T]) -> {?u32(X3,X2,X1,X0),T}; +%% Currently not used i.e only used by SCTP that does not dec_value/2 +%% dec_value(uint32, [X3,X2,X1,X0|T]) -> {?u32(X3,X2,X1,X0),T}; +%% dec_value(uint24, [X2,X1,X0|T]) -> {?u24(X2,X1,X0),T}; +%% dec_value(uint16, [X1,X0|T]) -> {?u16(X1,X0),T}; +%% dec_value(uint8, [X0|T]) -> {?u8(X0),T}; +dec_value(time, [X3,X2,X1,X0|T]) -> + case ?i32(X3,X2,X1,X0) of + -1 -> {infinity, T}; + Val -> {Val, T} + end; +dec_value(ip, [A,B,C,D|T]) -> {{A,B,C,D}, T}; +dec_value(ether,[X1,X2,X3,X4,X5,X6|T]) -> {[X1,X2,X3,X4,X5,X6],T}; +dec_value({enum,List}, [X3,X2,X1,X0|T]) -> + Val = ?i32(X3,X2,X1,X0), + case enum_name(Val, List) of + {name, Enum} -> {Enum, T}; + _ -> {undefined, T} + end; +dec_value({bitenumlist,List}, [X3,X2,X1,X0|T]) -> + Val = ?i32(X3,X2,X1,X0), + {enum_names(Val, List), T}; +%% Currently not used i.e only used by SCTP that does not dec_value/2 +%% dec_value({bitenumlist,List,Type}, T0) -> +%% {Val,T} = dec_value(Type, T0), +%% {enum_names(Val, List), T}; +dec_value(binary,[L0,L1,L2,L3|List]) -> + Len = ?i32(L0,L1,L2,L3), + {X,T}=lists:split(Len,List), + {list_to_binary(X),T}; +dec_value(Types, List) when is_tuple(Types) -> + {L,T} = dec_value_tuple(Types, List, 1, []), + {list_to_tuple(L),T}; +dec_value(Type, Val) -> + erlang:error({decode,Type,Val}). +%% dec_value(_, B) -> +%% {undefined, B}. + +dec_value_tuple(Types, List, N, Acc) + when is_integer(N), N =< tuple_size(Types) -> + {Term,Tail} = dec_value(element(N, Types), List), + dec_value_tuple(Types, Tail, N+1, [Term|Acc]); +dec_value_tuple(_, List, _, Acc) -> + {lists:reverse(Acc),List}. + +borlist([V|Vs], Value) -> + borlist(Vs, V bor Value); +borlist([], Value) -> Value. + + +enum_vals([Enum|Es], List) -> + case enum_val(Enum, List) of + false -> false; + {value,Value} -> [Value | enum_vals(Es, List)] + end; +enum_vals([], _) -> []. + +enum_names(Val, [{Enum,BitVal} |List]) -> + if Val band BitVal =:= BitVal -> + [Enum | enum_names(Val, List)]; + true -> + enum_names(Val, List) + end; +enum_names(_, []) -> []. + +enum_val(Enum, [{Enum,Value}|_]) -> {value,Value}; +enum_val(Enum, [_|List]) -> enum_val(Enum, List); +enum_val(_, []) -> false. + +enum_name(Val, [{Enum,Val}|_]) -> {name,Enum}; +enum_name(Val, [_|List]) -> enum_name(Val, List); +enum_name(_, []) -> false. + + + +%% Encoding for setopts +%% +%% encode opt/val REVERSED since options are stored in reverse order +%% i.e. the recent options first (we must process old -> new) +encode_opt_val(Opts) -> + try + enc_opt_val(Opts, []) + catch + Reason -> {error,Reason} + end. + +enc_opt_val([{active,once}|Opts], Acc) -> + %% Specially optimized because {active,once} will be used for + %% every packet, not only once when initializing the socket. + %% Measurements show that this optimization is worthwhile. + enc_opt_val(Opts, [<<?INET_LOPT_ACTIVE:8,?INET_ONCE:32>>|Acc]); +enc_opt_val([{raw,P,O,B}|Opts], Acc) -> + enc_opt_val(Opts, Acc, raw, {P,O,B}); +enc_opt_val([{Opt,Val}|Opts], Acc) -> + enc_opt_val(Opts, Acc, Opt, Val); +enc_opt_val([binary|Opts], Acc) -> + enc_opt_val(Opts, Acc, mode, binary); +enc_opt_val([list|Opts], Acc) -> + enc_opt_val(Opts, Acc, mode, list); +enc_opt_val([_|_], _) -> {error,einval}; +enc_opt_val([], Acc) -> {ok,Acc}. + +enc_opt_val(Opts, Acc, Opt, Val) when is_atom(Opt) -> + Type = type_opt(set, Opt), + case type_value(set, Type, Val) of + true -> + enc_opt_val(Opts, [enc_opt(Opt),enc_value(set, Type, Val)|Acc]); + false -> {error,einval} + end; +enc_opt_val(_, _, _, _) -> {error,einval}. + + + +%% Encoding for getopts +%% +%% "encode_opts" is for "getopt" only, not setopt". But it uses "enc_opt" which +%% is common for "getopt" and "setopt": +encode_opts(Opts) -> + try enc_opts(Opts) of + Buf -> {ok,Buf} + catch + Error -> {error,Error} + end. + +% Raw options are a special case, they need to be rewritten to be properly +% handled and the types need checking even when querying. +enc_opts([{raw,P,O,S}|Opts]) -> + enc_opts(Opts, raw, {P,O,S}); +enc_opts([{Opt,Val}|Opts]) -> + enc_opts(Opts, Opt, Val); +enc_opts([Opt|Opts]) -> + enc_opts(Opts, Opt); +enc_opts([]) -> []. + +enc_opts(Opts, Opt) when is_atom(Opt) -> + Type = type_opt(get, Opt), + case type_value(get, Type) of + true -> + [enc_opt(Opt),enc_value(get, Type)|enc_opts(Opts)]; + false -> + throw(einval) + end; +enc_opts(_, _) -> + throw(einval). + +enc_opts(Opts, Opt, Val) when is_atom(Opt) -> + Type = type_opt(get, Opt), + case type_value(get, Type, Val) of + true -> + [enc_opt(Opt),enc_value(get, Type, Val)|enc_opts(Opts)]; + false -> + throw(einval) + end; +enc_opts(_, _, _) -> + throw(einval). + + + +%% Decoding of raw list data options +%% +decode_opt_val(Buf) -> + try dec_opt_val(Buf) of + Result -> {ok,Result} + catch + Error -> {error,Error} + end. + +dec_opt_val([B|Buf]=BBuf) -> + case dec_opt(B) of + undefined -> + erlang:error({decode,BBuf}); + Opt -> + Type = type_opt(dec, Opt), + dec_opt_val(Buf, Opt, Type) + end; +dec_opt_val([]) -> []. + +dec_opt_val(Buf, raw, Type) -> + {{P,O,B},T} = dec_value(Type, Buf), + [{raw,P,O,B}|dec_opt_val(T)]; +dec_opt_val(Buf, Opt, Type) -> + {Val,T} = dec_value(Type, Buf), + [{Opt,Val}|dec_opt_val(T)]. + + + +%% Pre-processing of options for chgopts +%% +%% Return list of option requests for getopts +%% for all options that containing 'undefined' record fields. +%% +need_template([{Opt,undefined}=OV|Opts]) when is_atom(Opt) -> + [OV|need_template(Opts)]; +need_template([{Opt,Val}|Opts]) when is_atom(Opt) -> + case need_template(Val, 2) of + true -> + [{Opt,undefined}|need_template(Opts)]; + false -> + need_template(Opts) + end; +need_template([_|Opts]) -> + need_template(Opts); +need_template([]) -> []. +%% +need_template(T, N) when is_integer(N), N =< tuple_size(T) -> + case element(N, T) of + undefined -> true; + _ -> + need_template(T, N+1) + end; +need_template(_, _) -> false. + +%% Replace 'undefined' record fields in option values with values +%% from template records. +%% +merge_options([{Opt,undefined}|Opts], [{Opt,_}=T|Templates]) -> + [T|merge_options(Opts, Templates)]; +merge_options([{Opt,Val}|Opts], [{Opt,Template}|Templates]) + when is_atom(Opt), tuple_size(Val) >= 2 -> + Key = element(1, Val), + Size = tuple_size(Val), + if Size =:= tuple_size(Template), Key =:= element(1, Template) -> + %% is_record(Template, Key) + [{Opt,list_to_tuple([Key|merge_fields(Val, Template, 2)])} + |merge_options(Opts, Templates)]; + true -> + throw({merge,Val,Template}) + end; +merge_options([OptVal|Opts], Templates) -> + [OptVal|merge_options(Opts, Templates)]; +merge_options([], []) -> []; +merge_options(Opts, Templates) -> + throw({merge,Opts,Templates}). + +merge_fields(Opt, Template, N) when is_integer(N), N =< tuple_size(Opt) -> + case element(N, Opt) of + undefined -> + [element(N, Template)|merge_fields(Opt, Template, N+1)]; + Val -> + [Val|merge_fields(Opt, Template, N+1)] + end; +merge_fields(_, _, _) -> []. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% handle interface options +%% +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +type_ifopt(addr) -> ip; +type_ifopt(broadaddr) -> ip; +type_ifopt(dstaddr) -> ip; +type_ifopt(mtu) -> int; +type_ifopt(netmask) -> ip; +type_ifopt(flags) -> + {bitenumlist, + [{up, ?INET_IFF_UP}, + {down, ?INET_IFF_DOWN}, + {broadcast, ?INET_IFF_BROADCAST}, + {no_broadcast, ?INET_IFF_NBROADCAST}, + {loopback, ?INET_IFF_LOOPBACK}, + {pointtopoint, ?INET_IFF_POINTTOPOINT}, + {no_pointtopoint, ?INET_IFF_NPOINTTOPOINT}, + {running, ?INET_IFF_RUNNING}, + {multicast, ?INET_IFF_MULTICAST}]}; +type_ifopt(hwaddr) -> ether; +type_ifopt(Opt) when is_atom(Opt) -> undefined. + +enc_ifopt(addr) -> ?INET_IFOPT_ADDR; +enc_ifopt(broadaddr) -> ?INET_IFOPT_BROADADDR; +enc_ifopt(dstaddr) -> ?INET_IFOPT_DSTADDR; +enc_ifopt(mtu) -> ?INET_IFOPT_MTU; +enc_ifopt(netmask) -> ?INET_IFOPT_NETMASK; +enc_ifopt(flags) -> ?INET_IFOPT_FLAGS; +enc_ifopt(hwaddr) -> ?INET_IFOPT_HWADDR; +enc_ifopt(Opt) when is_atom(Opt) -> -1. + +dec_ifopt(?INET_IFOPT_ADDR) -> addr; +dec_ifopt(?INET_IFOPT_BROADADDR) -> broadaddr; +dec_ifopt(?INET_IFOPT_DSTADDR) -> dstaddr; +dec_ifopt(?INET_IFOPT_MTU) -> mtu; +dec_ifopt(?INET_IFOPT_NETMASK) -> netmask; +dec_ifopt(?INET_IFOPT_FLAGS) -> flags; +dec_ifopt(?INET_IFOPT_HWADDR) -> hwaddr; +dec_ifopt(I) when is_integer(I) -> undefined. + +%% decode if options returns a reversed list +decode_ifopts([B | Buf], Acc) -> + case dec_ifopt(B) of + undefined -> + {error, einval}; + Opt -> + {Val,T} = dec_value(type_ifopt(Opt), Buf), + decode_ifopts(T, [{Opt,Val} | Acc]) + end; +decode_ifopts(_,Acc) -> {ok,Acc}. + + +%% encode if options return a reverse list +encode_ifopts([Opt|Opts], Acc) -> + case enc_ifopt(Opt) of + -1 -> {error,einval}; + B -> encode_ifopts(Opts,[B|Acc]) + end; +encode_ifopts([],Acc) -> {ok,Acc}. + + +%% encode if options return a reverse list +encode_ifopt_val([{Opt,Val}|Opts], Buf) -> + Type = type_ifopt(Opt), + try type_value(set, Type, Val) of + true -> + encode_ifopt_val(Opts, + [Buf,enc_ifopt(Opt),enc_value(set, Type, Val)]); + false -> {error,einval} + catch + Reason -> {error,Reason} + end; +encode_ifopt_val([], Buf) -> {ok,Buf}. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% handle subscribe options +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +encode_subs(L) -> + try enc_subs(L) of + Result -> {ok,Result} + catch + Error -> {error,Error} + end. + +enc_subs([H|T]) -> + case H of + subs_empty_out_q -> [?INET_SUBS_EMPTY_OUT_Q|enc_subs(T)]%; + %%Dialyzer _ -> throw(einval) + end; +enc_subs([]) -> []. + + +decode_subs(Bytes) -> + try dec_subs(Bytes) of + Result -> {ok,Result} + catch + Error -> {error,Error} + end. + +dec_subs([X,X3,X2,X1,X0|R]) -> + Val = ?u32(X3,X2,X1,X0), + case X of + ?INET_SUBS_EMPTY_OUT_Q -> [{subs_empty_out_q,Val}|dec_subs(R)]; + _ -> throw(einval) + end; +dec_subs([]) -> []. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% handle statictics options +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +encode_stats(L) -> + try enc_stats(L) of + Result -> {ok,Result} + catch + Error -> {error,Error} + end. + +enc_stats([H|T]) -> + case H of + recv_cnt -> [?INET_STAT_RECV_CNT |enc_stats(T)]; + recv_max -> [?INET_STAT_RECV_MAX |enc_stats(T)]; + recv_avg -> [?INET_STAT_RECV_AVG |enc_stats(T)]; + recv_dvi -> [?INET_STAT_RECV_DVI |enc_stats(T)]; + send_cnt -> [?INET_STAT_SEND_CNT |enc_stats(T)]; + send_max -> [?INET_STAT_SEND_MAX |enc_stats(T)]; + send_avg -> [?INET_STAT_SEND_AVG |enc_stats(T)]; + send_pend -> [?INET_STAT_SEND_PEND|enc_stats(T)]; + send_oct -> [?INET_STAT_SEND_OCT |enc_stats(T)]; + recv_oct -> [?INET_STAT_RECV_OCT |enc_stats(T)]; + _ -> throw(einval) + end; +enc_stats([]) -> []. + + +decode_stats(Bytes) -> + try dec_stats(Bytes) of + Result -> {ok,Result} + catch + Error -> {error,Error} + end. + + +dec_stats([?INET_STAT_SEND_OCT,X7,X6,X5,X4,X3,X2,X1,X0|R]) -> + Val = ?u64(X7,X6,X5,X4,X3,X2,X1,X0), + [{send_oct, Val}|dec_stats(R)]; +dec_stats([?INET_STAT_RECV_OCT,X7,X6,X5,X4,X3,X2,X1,X0|R]) -> + Val = ?u64(X7,X6,X5,X4,X3,X2,X1,X0), + [{recv_oct, Val}|dec_stats(R)]; +dec_stats([X,X3,X2,X1,X0|R]) -> + Val = ?u32(X3,X2,X1,X0), + case X of + ?INET_STAT_RECV_CNT -> [{recv_cnt,Val} |dec_stats(R)]; + ?INET_STAT_RECV_MAX -> [{recv_max,Val} |dec_stats(R)]; + ?INET_STAT_RECV_AVG -> [{recv_avg,Val} |dec_stats(R)]; + ?INET_STAT_RECV_DVI -> [{recv_dvi,Val} |dec_stats(R)]; + ?INET_STAT_SEND_CNT -> [{send_cnt,Val} |dec_stats(R)]; + ?INET_STAT_SEND_MAX -> [{send_max,Val} |dec_stats(R)]; + ?INET_STAT_SEND_AVG -> [{send_avg,Val} |dec_stats(R)]; + ?INET_STAT_SEND_PEND -> [{send_pend,Val}|dec_stats(R)]; + _ -> throw(einval) + end; +dec_stats([]) -> []. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% handle status options +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +dec_status(Flags) -> + enum_names(Flags, + [ + {busy, ?INET_F_BUSY}, + %% {listening, ?INET_F_LST}, NOT USED ANY MORE + {accepting, ?INET_F_ACC}, + {connecting, ?INET_F_CON}, + {listen, ?INET_F_LISTEN}, + {connected, ?INET_F_ACTIVE}, + {bound, ?INET_F_BOUND}, + {open, ?INET_F_OPEN} + ]). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% +%% UTILS +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +enc_time(Time) when Time < 0 -> [255,255,255,255]; +enc_time(Time) -> ?int32(Time). + +encode_ifname(Name) when is_atom(Name) -> encode_ifname(atom_to_list(Name)); +encode_ifname(Name) -> + N = length(Name), + if N > 255 -> {error, einval}; + true -> {ok,[N | Name]} + end. + +build_iflist(Cs) -> + build_iflist(Cs, [], []). + +%% Turn a NULL separated list of chars into a list of strings, removing +%% duplicates. +build_iflist([0|L], Acc, [H|T]) -> + case rev(Acc) of + H -> build_iflist(L, [], [H|T]); + N -> build_iflist(L, [], [N,H|T]) + end; +build_iflist([0|L], Acc, []) -> + build_iflist(L, [], [rev(Acc)]); +build_iflist([C|L], Acc, List) -> + build_iflist(L, [C|Acc], List); +build_iflist([], [], List) -> + rev(List); +build_iflist([], Acc, List) -> + build_iflist([0], Acc, List). + +rev(L) -> rev(L,[]). +rev([C|L],Acc) -> rev(L,[C|Acc]); +rev([],Acc) -> Acc. + +ip_to_bytes(IP) when tuple_size(IP) =:= 4 -> ip4_to_bytes(IP); +ip_to_bytes(IP) when tuple_size(IP) =:= 8 -> ip6_to_bytes(IP). + +ip4_to_bytes({A,B,C,D}) -> + [A band 16#ff, B band 16#ff, C band 16#ff, D band 16#ff]. + +ip6_to_bytes({A,B,C,D,E,F,G,H}) -> + [?int16(A), ?int16(B), ?int16(C), ?int16(D), + ?int16(E), ?int16(F), ?int16(G), ?int16(H)]. + +get_ip(?INET_AF_INET, Addr) -> get_ip4(Addr); +get_ip(?INET_AF_INET6, Addr) -> get_ip6(Addr). + +get_ip4([A,B,C,D | T]) -> {{A,B,C,D},T}. + +get_ip6([X1,X2,X3,X4,X5,X6,X7,X8,X9,X10,X11,X12,X13,X14,X15,X16 | T]) -> + { { ?u16(X1,X2),?u16(X3,X4),?u16(X5,X6),?u16(X7,X8), + ?u16(X9,X10),?u16(X11,X12),?u16(X13,X14),?u16(X15,X16)}, T}. + + +%% Control command +ctl_cmd(Port, Cmd, Args) -> + ?DBG_FORMAT("prim_inet:ctl_cmd(~p, ~p, ~p)~n", [Port,Cmd,Args]), + Result = + try erlang:port_control(Port, Cmd, Args) of + [?INET_REP_OK|Reply] -> {ok,Reply}; + [?INET_REP_SCTP] -> {error,sctp_reply}; + [?INET_REP_ERROR|Err] -> {error,list_to_atom(Err)} + catch + error:_ -> {error,einval} + end, + ?DBG_FORMAT("prim_inet:ctl_cmd() -> ~p~n", [Result]), + Result. diff --git a/erts/preloaded/src/prim_zip.erl b/erts/preloaded/src/prim_zip.erl new file mode 100644 index 0000000000..17ef8c6c43 --- /dev/null +++ b/erts/preloaded/src/prim_zip.erl @@ -0,0 +1,604 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2008-2009. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% + +%% zip functions that are used by code_server + +-module(prim_zip). + +%% unzipping piecemal +-export([ + open/1, + open/3, + foldl/3, + close/1 + ]). + +%% Internal function. Exported to avoid dialyzer warnings +-export([splitter/3]). + +%% includes +-include_lib("kernel/include/file.hrl"). % #file_info +-include_lib("stdlib/include/zip.hrl"). % #zip_file, #zip_comment +-include("zip_internal.hrl"). % #cd_file_header etc + +%% max bytes read from files and archives (and fed to zlib) +-define(READ_BLOCK_SIZE, 16*1024). + +%% for debugging, to turn off catch +-define(CATCH, catch). + +-record(primzip_file, + {name, + get_info, + get_bin}). + +-record(primzip, + {files = [] :: [#primzip_file{}], + zlib, % handle to the zlib port from zlib:open + input, % fun/2 for file/memory input + in}). % input (file handle or binary) + +filter_fun() -> + Continue = true, + Include = true, + fun({_Name, _GetInfoFun, _GetBinFun}, Acc) -> + {Continue, Include, Acc} + end. + +%% Open a zip archive +open(F) -> + open(filter_fun(), undefined, F). + +open(FilterFun, FilterAcc, F) -> + case ?CATCH do_open(FilterFun, FilterAcc, F) of + {ok, PrimZip, Acc} -> + {ok, PrimZip, Acc}; + Error -> + {error, Error} + end. + +do_open(FilterFun, FilterAcc, F) -> + Input = get_zip_input(F), + In0 = Input({open, F, [read, binary, raw]}, []), + Z = zlib:open(), + PrimZip = #primzip{files = [], zlib = Z, in = In0, input = Input}, + {PrimZip2, FilterAcc2} = get_central_dir(PrimZip, FilterFun, FilterAcc), + {ok, PrimZip2, FilterAcc2}. + +%% iterate over all files in a zip archive +foldl(FilterFun, FilterAcc, #primzip{files = Files} = PrimZip) -> + case ?CATCH do_foldl(FilterFun, FilterAcc, Files, [], PrimZip, PrimZip) of + {ok, FilterAcc2, PrimZip2} -> {ok, PrimZip2, FilterAcc2}; + Error -> {error, Error} + end; +foldl(_, _, _) -> + {error, einval}. + +do_foldl(FilterFun, FilterAcc, [PF | Tail], Acc0, PrimZip, PrimZipOrig) -> + #primzip_file{name = F, get_info = GetInfo, get_bin = GetBin} = PF, + case FilterFun({F, GetInfo, GetBin}, FilterAcc) of + {Continue, Include, FilterAcc2} -> + Acc1 = + case Include of + false -> Acc0; + true -> [PF | Acc0]; + {true, Nick} -> [PF#primzip_file{name = Nick} | Acc0] + end, + case Continue of + true -> + do_foldl(FilterFun, FilterAcc2, Tail, Acc1, PrimZip, PrimZipOrig); + false -> + {ok, FilterAcc2, PrimZipOrig} + end; + FilterRes -> + throw({illegal_filter, FilterRes}) + end; +do_foldl(_FilterFun, FilterAcc, [], Acc, PrimZip, _PrimZipOrig) -> + {ok, FilterAcc, PrimZip#primzip{files = reverse(Acc)}}. + +%% close a zip archive +close(#primzip{in = In0, input = Input, zlib = Z}) -> + Input(close, In0), + zlib:close(Z); +close(_) -> + {error, einval}. + +get_zip_input({F, B}) when is_binary(B), is_list(F) -> + fun binary_io/2; +get_zip_input(F) when is_list(F) -> + fun prim_file_io/2. + +%% get a file from the archive +get_z_file(F, Offset, ChunkSize, #primzip{zlib = Z, in = In0, input = Input}) -> + case Input({pread, Offset, ChunkSize}, In0) of + {<<?LOCAL_FILE_MAGIC:32/little, + BLH:(?LOCAL_FILE_HEADER_SZ-4)/binary, _/binary>> = B, _In1} -> + #local_file_header{gp_flag = GPFlag, + file_name_length = FNLen, + extra_field_length = EFLen, + comp_method = CompMethod} = + local_file_header_from_bin(BLH, F), + DataOffs = ?LOCAL_FILE_HEADER_SZ + FNLen + EFLen + + offset_over_z_data_descriptor(GPFlag), + case B of + <<_:DataOffs/binary, Data/binary>> -> + Out = get_z_all(CompMethod, Data, Z, F), + %%{Out, CRC} = get_z_all(CompMethod, Data, Z, F), + %%CRC == CRC32 orelse throw({bad_crc, F}), + Out; + _ -> + throw({bad_local_file_offset, F}) + end; + _ -> + throw({bad_local_file_header, F}) + end. + +%% flag for zlib +-define(MAX_WBITS, 15). + +%% get compressed or stored data +get_z_all(?DEFLATED, Compressed, Z, _F) -> + ok = zlib:inflateInit(Z, -?MAX_WBITS), + Uncompressed = zlib:inflate(Z, Compressed), + %%_CRC = zlib:crc32(Z), + ?CATCH zlib:inflateEnd(Z), + erlang:iolist_to_binary(Uncompressed); % {erlang:iolist_to_binary(Uncompressed), CRC} +get_z_all(?STORED, Stored, _Z, _F) -> + %%CRC0 = zlib:crc32(Z, <<>>), + %%CRC1 = zlib:crc32(Z, CRC0, Stored), + Stored; % {Stored, CRC1}; +get_z_all(CompMethod, _, _, F) -> + throw({unsupported_compression, F, CompMethod}). + +%% skip data descriptor if any +offset_over_z_data_descriptor(GPFlag) when GPFlag band 8 =:= 8 -> + 12; +offset_over_z_data_descriptor(_GPFlag) -> + 0. + +%% get the central directory from the archive +get_central_dir(#primzip{in = In0, input = Input} = PrimZip, FilterFun, FilterAcc) -> + {B, In1} = get_end_of_central_dir(In0, ?END_OF_CENTRAL_DIR_SZ, Input), + {EOCD, _BComment} = eocd_and_comment_from_bin(B), + {BCD, In2} = Input({pread, EOCD#eocd.offset, EOCD#eocd.size}, In1), + N = EOCD#eocd.entries, + EndOffset = EOCD#eocd.offset, + PrimZip2 = PrimZip#primzip{in = In2}, + if + N =:= 0 -> + {PrimZip2, FilterAcc}; + true -> + {F, Offset, CFH, BCDRest} = get_file_header(BCD), + get_cd_loop(N, BCDRest, [], PrimZip2, F, Offset, CFH, EndOffset, FilterFun, FilterAcc, PrimZip) + end. + +get_cd_loop(N, BCD, Acc0, PrimZip, FileName, Offset, CFH, EndOffset, FilterFun, FilterAcc, PrimZipOrig) -> + {NextF, NextOffset, NextCFH, BCDRest, Size} = + if + N =:= 1 -> + {undefined, undefined, undefined, undefined, EndOffset - Offset}; + true -> + {NextF0, NextOffset0, NextCFH0, BCDRest0} = get_file_header(BCD), + {NextF0, NextOffset0, NextCFH0, BCDRest0, NextOffset0 - Offset} + end, + %% erlang:display({FileName, N, Offset, Size, NextPF}), + GetInfo = fun() -> cd_file_header_to_file_info(FileName, CFH, <<>>) end, + GetBin = fun() -> get_z_file(FileName, Offset, Size, PrimZip) end, + PF = #primzip_file{name = FileName, get_info = GetInfo, get_bin = GetBin}, + case FilterFun({FileName, GetInfo, GetBin}, FilterAcc) of + {Continue, Include, FilterAcc2} -> + Acc1 = + case Include of + false -> Acc0; + true -> [PF | Acc0]; + {true, Nick} -> [PF#primzip_file{name = Nick} | Acc0] + end, + case Continue of + true when N > 1 -> + get_cd_loop(N-1, BCDRest, Acc1, PrimZip, NextF, NextOffset, NextCFH, EndOffset, FilterFun, FilterAcc2, PrimZipOrig); + true -> + PrimZip2 = PrimZip#primzip{files = reverse(Acc1)}, + {PrimZip2, FilterAcc2}; + false -> + {PrimZipOrig, FilterAcc2} + end; + FilterRes -> + throw({illegal_filter, FilterRes}) + end. + +get_file_header(BCD) -> + BCFH = + case BCD of + <<?CENTRAL_FILE_MAGIC:32/little, + B:(?CENTRAL_FILE_HEADER_SZ-4)/binary, + _/binary>> -> + B; + _ -> + throw(bad_central_directory) + end, + CFH = cd_file_header_from_bin(BCFH), + FileNameLen = CFH#cd_file_header.file_name_length, + ExtraLen = CFH#cd_file_header.extra_field_length, + CommentLen = CFH#cd_file_header.file_comment_length, + ToGet = FileNameLen + ExtraLen + CommentLen, + {B2, BCDRest} = + case BCD of + <<_:?CENTRAL_FILE_HEADER_SZ/binary, + G:ToGet/binary, + Rest/binary>> -> + {G, Rest}; + _ -> + throw(bad_central_directory) + end, + FileName = get_filename_from_b2(B2, FileNameLen, ExtraLen, CommentLen), + Offset = CFH#cd_file_header.local_header_offset, + {FileName, Offset, CFH, BCDRest}. + +get_filename_from_b2(B, FileNameLen, ExtraLen, CommentLen) -> + case B of + <<BFileName:FileNameLen/binary, + _BExtra:ExtraLen/binary, + _BComment:CommentLen/binary>> -> + binary_to_list(BFileName); + _ -> + throw(bad_central_directory) + end. + +%% get end record, containing the offset to the central directory +%% the end record is always at the end of the file BUT alas it is +%% of variable size (yes that's dumb!) +get_end_of_central_dir(_In, Sz, _Input) when Sz > 16#ffff -> + throw(bad_eocd); +get_end_of_central_dir(In0, Sz, Input) -> + In1 = Input({seek, eof, -Sz}, In0), + {B, In2} = Input({read, Sz}, In1), + case find_eocd_header(B) of + none -> + get_end_of_central_dir(In2, Sz+Sz, Input); + Header -> + {Header, In2} + end. + +%% find the end record by matching for it +find_eocd_header(<<?END_OF_CENTRAL_DIR_MAGIC:32/little, Rest/binary>>) -> + Rest; +find_eocd_header(<<_:8, Rest/binary>>) + when byte_size(Rest) > ?END_OF_CENTRAL_DIR_SZ-4 -> + find_eocd_header(Rest); +find_eocd_header(_) -> + none. + +%% io objects +prim_file_io({file_info, F}, _) -> + case prim_file:read_file_info(F) of + {ok, Info} -> Info; + {error, E} -> throw(E) + end; +prim_file_io({open, FN, Opts}, _) -> + case ?CATCH prim_file:open(FN, Opts++[binary]) of + {ok, H} -> + H; + {error, E} -> + throw(E) + end; +prim_file_io({read, N}, H) -> + case prim_file:read(H, N) of + {ok, B} -> {B, H}; + eof -> {eof, H}; + {error, E} -> throw(E) + end; +prim_file_io({pread, Pos, N}, H) -> + case prim_file:pread(H, Pos, N) of + {ok, B} -> {B, H}; + eof -> {eof, H}; + {error, E} -> throw(E) + end; +prim_file_io({seek, S, Pos}, H) -> + case prim_file:position(H, {S, Pos}) of + {ok, _NewPos} -> H; + {error, Error} -> throw(Error) + end; +prim_file_io({write, Data}, H) -> + case prim_file:write(H, Data) of + ok -> H; + {error, Error} -> throw(Error) + end; +prim_file_io({pwrite, Pos, Data}, H) -> + case prim_file:pwrite(H, Pos, Data) of + ok -> H; + {error, Error} -> throw(Error) + end; +prim_file_io({close, FN}, H) -> + case prim_file:close(H) of + ok -> FN; + {error, Error} -> throw(Error) + end; +prim_file_io(close, H) -> + prim_file_io({close, ok}, H); +prim_file_io({set_file_info, F, FI}, H) -> + case prim_file:write_file_info(F, FI) of + ok -> H; + {error, Error} -> throw(Error) + end. + +binary_io({pread, NewPos, N}, {OldPos, B}) -> + case B of + <<_:NewPos/binary, Read:N/binary, _Rest/binary>> -> + {Read, {NewPos+N, B}}; + _ -> + {eof, {OldPos, B}} + end; +binary_io({read, N}, {Pos, B}) when Pos >= byte_size(B) -> + {eof, {Pos+N, B}}; +binary_io({read, N}, {Pos, B}) when Pos + N > byte_size(B) -> + case B of + <<_:Pos/binary, Read/binary>> -> + {Read, {byte_size(B), B}}; + _ -> + {eof, {Pos, B}} + end; +binary_io({read, N}, {Pos, B}) -> + case B of + <<_:Pos/binary, Read:N/binary, _/binary>> -> + {Read, {Pos+N, B}}; + _ -> + {eof, {Pos, B}} + end; +binary_io({seek, bof, Pos}, {_OldPos, B}) -> + {Pos, B}; +binary_io({seek, cur, Pos}, {OldPos, B}) -> + {OldPos + Pos, B}; +binary_io({seek, eof, Pos}, {_OldPos, B}) -> + {byte_size(B) + Pos, B}; +binary_io({file_info, {_Filename, B}}, A) -> + binary_io({file_info, B}, A); +binary_io({file_info, B}, _) -> + {Type, Size} = + if + is_binary(B) -> {regular, byte_size(B)}; + B =:= directory -> {directory, 0} + end, + Now = calendar:local_time(), + #file_info{size = Size, type = Type, access = read_write, + atime = Now, mtime = Now, ctime = Now, + mode = 0, links = 1, major_device = 0, + minor_device = 0, inode = 0, uid = 0, gid = 0}; +binary_io({pwrite, Pos, Data}, {OldPos, B}) -> + {OldPos, pwrite_binary(B, Pos, Data)}; +binary_io({write, Data}, {Pos, B}) -> + {Pos + erlang:iolist_size(Data), pwrite_binary(B, Pos, Data)}; +binary_io({open, {_Filename, B}, _Opts}, _) -> + {0, B}; +binary_io({open, B, _Opts}, _) when is_binary(B) -> + {0, B}; +binary_io({open, Filename, _Opts}, _) when is_list(Filename) -> + {0, <<>>}; +binary_io(close, {_Pos, B}) -> + B; +binary_io({close, FN}, {_Pos, B}) -> + {FN, B}. + +%% ZIP header manipulations +eocd_and_comment_from_bin(<<DiskNum:16/little, + StartDiskNum:16/little, + EntriesOnDisk:16/little, + Entries:16/little, + Size:32/little, + Offset:32/little, + ZipCommentLength:16/little, + Comment:ZipCommentLength/binary>>) -> + {#eocd{disk_num = DiskNum, + start_disk_num = StartDiskNum, + entries_on_disk = EntriesOnDisk, + entries = Entries, + size = Size, + offset = Offset, + zip_comment_length = ZipCommentLength}, + Comment}; +eocd_and_comment_from_bin(_) -> + throw(bad_eocd). + +%% make a file_info from a central directory header +cd_file_header_to_file_info(FileName, + #cd_file_header{uncomp_size = UncompSize, + last_mod_time = ModTime, + last_mod_date = ModDate}, + ExtraField) when is_binary(ExtraField) -> + T = dos_date_time_to_datetime(ModDate, ModTime), + Type = + case last(FileName) of + $/ -> directory; + _ -> regular + end, + FI = #file_info{size = UncompSize, + type = Type, + access = read_write, + atime = T, + mtime = T, + ctime = T, + mode = 8#066, + links = 1, + major_device = 0, + minor_device = 0, + inode = 0, + uid = 0, + gid = 0}, + add_extra_info(FI, ExtraField). + +%% add extra info to file (some day when we implement it) +%% add_extra_info(FI, <<?EXTENDED_TIMESTAMP_TAG:16/little, _Rest/binary>>) -> +%% FI; % not yet supported, some other day... +%% add_extra_info(FI, <<?UNIX_EXTRA_FIELD_TAG:16/little, Rest/binary>>) -> +%% _UnixExtra = unix_extra_field_and_var_from_bin(Rest), +%% FI; % not yet supported, and not widely used +add_extra_info(FI, _) -> + FI. +%% +%% unix_extra_field_and_var_from_bin(<<TSize:16/little, +%% ATime:32/little, +%% MTime:32/little, +%% UID:16/little, +%% GID:16/little, +%% Var:TSize/binary>>) -> +%% {#unix_extra_field{atime = ATime, +%% mtime = MTime, +%% uid = UID, +%% gid = GID}, +%% Var}; +%% unix_extra_field_and_var_from_bin(_) -> +%% throw(bad_unix_extra_field). + +%% convert between erlang datetime and the MSDOS date and time +%% that's stored in the zip archive +%% MSDOS Time MSDOS Date +%% bit 0 - 4 5 - 10 11 - 15 16 - 20 21 - 24 25 - 31 +%% value second minute hour day (1 - 31) month (1 - 12) years from 1980 +dos_date_time_to_datetime(DosDate, DosTime) -> + <<Hour:5, Min:6, Sec:5>> = <<DosTime:16>>, + <<YearFrom1980:7, Month:4, Day:5>> = <<DosDate:16>>, + {{YearFrom1980+1980, Month, Day}, + {Hour, Min, Sec}}. + +cd_file_header_from_bin(<<VersionMadeBy:16/little, + VersionNeeded:16/little, + GPFlag:16/little, + CompMethod:16/little, + LastModTime:16/little, + LastModDate:16/little, + CRC32:32/little, + CompSize:32/little, + UncompSize:32/little, + FileNameLength:16/little, + ExtraFieldLength:16/little, + FileCommentLength:16/little, + DiskNumStart:16/little, + InternalAttr:16/little, + ExternalAttr:32/little, + LocalHeaderOffset:32/little>>) -> + #cd_file_header{version_made_by = VersionMadeBy, + version_needed = VersionNeeded, + gp_flag = GPFlag, + comp_method = CompMethod, + last_mod_time = LastModTime, + last_mod_date = LastModDate, + crc32 = CRC32, + comp_size = CompSize, + uncomp_size = UncompSize, + file_name_length = FileNameLength, + extra_field_length = ExtraFieldLength, + file_comment_length = FileCommentLength, + disk_num_start = DiskNumStart, + internal_attr = InternalAttr, + external_attr = ExternalAttr, + local_header_offset = LocalHeaderOffset}; +cd_file_header_from_bin(_) -> + throw(bad_cd_file_header). + +local_file_header_from_bin(<<VersionNeeded:16/little, + GPFlag:16/little, + CompMethod:16/little, + LastModTime:16/little, + LastModDate:16/little, + CRC32:32/little, + CompSize:32/little, + UncompSize:32/little, + FileNameLength:16/little, + ExtraFieldLength:16/little>>, + _F) -> + #local_file_header{version_needed = VersionNeeded, + gp_flag = GPFlag, + comp_method = CompMethod, + last_mod_time = LastModTime, + last_mod_date = LastModDate, + crc32 = CRC32, + comp_size = CompSize, + uncomp_size = UncompSize, + file_name_length = FileNameLength, + extra_field_length = ExtraFieldLength}; +local_file_header_from_bin(_, F) -> + throw({bad_local_file_header, F}). + +%% A pwrite-like function for iolists (used by memory-option) + +split_iolist(B, Pos) when is_binary(B) -> + split_binary(B, Pos); +split_iolist(L, Pos) when is_list(L) -> + splitter([], L, Pos). + +splitter(Left, Right, 0) -> + {Left, Right}; +splitter(<<>>, Right, RelPos) -> + split_iolist(Right, RelPos); +splitter(Left, [A | Right], RelPos) when is_list(A) or is_binary(A) -> + Sz = erlang:iolist_size(A), + case Sz > RelPos of + true -> + {Leftx, Rightx} = split_iolist(A, RelPos), + {[Left | Leftx], [Rightx, Right]}; + _ -> + splitter([Left | A], Right, RelPos - Sz) + end; +splitter(Left, [A | Right], RelPos) when is_integer(A) -> + splitter([Left, A], Right, RelPos - 1); +splitter(Left, Right, RelPos) when is_binary(Right) -> + splitter(Left, [Right], RelPos). + +skip_iolist(B, Pos) when is_binary(B) -> + case B of + <<_:Pos/binary, Bin/binary>> -> Bin; + _ -> <<>> + end; +skip_iolist(L, Pos) when is_list(L) -> + skipper(L, Pos). + +skipper(Right, 0) -> + Right; +skipper([A | Right], RelPos) when is_list(A) or is_binary(A) -> + Sz = erlang:iolist_size(A), + case Sz > RelPos of + true -> + Rightx = skip_iolist(A, RelPos), + [Rightx, Right]; + _ -> + skip_iolist(Right, RelPos - Sz) + end; +skipper([A | Right], RelPos) when is_integer(A) -> + skip_iolist(Right, RelPos - 1). + +pwrite_iolist(Iolist, Pos, Bin) -> + {Left, Right} = split_iolist(Iolist, Pos), + Sz = erlang:iolist_size(Bin), + R = skip_iolist(Right, Sz), + [Left, Bin | R]. + +pwrite_binary(B, Pos, Bin) -> + erlang:iolist_to_binary(pwrite_iolist(B, Pos, Bin)). + +reverse(X) -> + reverse(X, []). + +reverse([H|T], Y) -> + reverse(T, [H|Y]); +reverse([], X) -> + X. + +last([E|Es]) -> last(E, Es). + +last(_, [E|Es]) -> last(E, Es); +last(E, []) -> E. diff --git a/erts/preloaded/src/zip_internal.hrl b/erts/preloaded/src/zip_internal.hrl new file mode 100644 index 0000000000..a8f7b1f1b7 --- /dev/null +++ b/erts/preloaded/src/zip_internal.hrl @@ -0,0 +1,103 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2008-2009. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% + +%% ZIP-file format records and defines + +%% compression methods +-define(STORED, 0). +-define(UNCOMPRESSED, 0). +-define(SHRUNK, 1). +-define(REDUCED_1, 2). +-define(REDUCED_2, 3). +-define(REDUCED_3, 4). +-define(REDUCED_4, 5). +-define(IMPLODED, 6). +-define(TOKENIZED, 7). +-define(DEFLATED, 8). +-define(DEFLATED_64, 9). +-define(PKWARE_IMPLODED, 10). +-define(PKWARE_RESERVED, 11). +-define(BZIP2_COMPRESSED, 12). + +%% zip-file records +-define(LOCAL_FILE_MAGIC,16#04034b50). +-define(LOCAL_FILE_HEADER_SZ,(4+2+2+2+2+2+4+4+4+2+2)). +-define(LOCAL_FILE_HEADER_CRC32_OFFSET, 4+2+2+2+2+2). +-record(local_file_header, {version_needed, + gp_flag, + comp_method, + last_mod_time, + last_mod_date, + crc32, + comp_size, + uncomp_size, + file_name_length, + extra_field_length}). + +-define(CENTRAL_FILE_HEADER_SZ,(4+2+2+2+2+2+2+4+4+4+2+2+2+2+2+4+4)). + +-define(CENTRAL_DIR_MAGIC, 16#06054b50). +-define(CENTRAL_DIR_SZ, (4+2+2+2+2+4+4+2)). +-define(CENTRAL_DIR_DIGITAL_SIG_MAGIC, 16#05054b50). +-define(CENTRAL_DIR_DIGITAL_SIG_SZ, (4+2)). + +-define(CENTRAL_FILE_MAGIC, 16#02014b50). + +-record(cd_file_header, {version_made_by, + version_needed, + gp_flag, + comp_method, + last_mod_time, + last_mod_date, + crc32, + comp_size, + uncomp_size, + file_name_length, + extra_field_length, + file_comment_length, + disk_num_start, + internal_attr, + external_attr, + local_header_offset}). + +%% Unix extra fields (not yet supported) +-define(UNIX_EXTRA_FIELD_TAG, 16#000d). +-record(unix_extra_field, {atime, + mtime, + uid, + gid}). + +%% extended timestamps (not yet supported) +-define(EXTENDED_TIMESTAMP_TAG, 16#5455). +-record(extended_timestamp, {mtime, + atime, + ctime}). + +-define(END_OF_CENTRAL_DIR_MAGIC, 16#06054b50). +-define(END_OF_CENTRAL_DIR_SZ, (4+2+2+2+2+4+4+2)). + +-record(eocd, {disk_num, + start_disk_num, + entries_on_disk, + entries, + size, + offset, + zip_comment_length}). + + diff --git a/erts/preloaded/src/zlib.erl b/erts/preloaded/src/zlib.erl new file mode 100644 index 0000000000..21971a75cf --- /dev/null +++ b/erts/preloaded/src/zlib.erl @@ -0,0 +1,421 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2003-2009. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% + +-module(zlib). + +-export([open/0,close/1,deflateInit/1,deflateInit/2,deflateInit/6, + deflateSetDictionary/2,deflateReset/1,deflateParams/3, + deflate/2,deflate/3,deflateEnd/1, + inflateInit/1,inflateInit/2,inflateSetDictionary/2, + inflateSync/1,inflateReset/1,inflate/2,inflateEnd/1, + setBufSize/2,getBufSize/1, + crc32/1,crc32/2,crc32/3,adler32/2,adler32/3,getQSize/1, + crc32_combine/4,adler32_combine/4, + compress/1,uncompress/1,zip/1,unzip/1, + gzip/1,gunzip/1]). + +%% flush argument encoding +-define(Z_NO_FLUSH, 0). +-define(Z_SYNC_FLUSH, 2). +-define(Z_FULL_FLUSH, 3). +-define(Z_FINISH, 4). + +%% compression level +-define(Z_NO_COMPRESSION, 0). +-define(Z_BEST_SPEED, 1). +-define(Z_BEST_COMPRESSION, 9). +-define(Z_DEFAULT_COMPRESSION, (-1)). + +%% compresssion strategy +-define(Z_FILTERED, 1). +-define(Z_HUFFMAN_ONLY, 2). +-define(Z_DEFAULT_STRATEGY, 0). + +%% deflate compression method +-define(Z_DEFLATED, 8). + +-define(Z_NULL, 0). + +-define(MAX_WBITS, 15). + +%% gzip defs (rfc 1952) + +-define(ID1, 16#1f). +-define(ID2, 16#8b). + +-define(FTEXT, 16#01). +-define(FHCRC, 16#02). +-define(FEXTRA, 16#04). +-define(FNAME, 16#08). +-define(FCOMMENT, 16#10). +-define(RESERVED, 16#E0). + +-define(OS_MDDOS, 0). +-define(OS_AMIGA, 1). +-define(OS_OPENVMS, 2). +-define(OS_UNIX, 3). +-define(OS_VMCMS, 4). +-define(OS_ATARI, 5). +-define(OS_OS2, 6). +-define(OS_MAC, 7). +-define(OS_ZSYS, 8). +-define(OS_CPM, 9). +-define(OS_TOP20, 10). +-define(OS_NTFS, 11). +-define(OS_QDOS, 12). +-define(OS_ACORN, 13). +-define(OS_UNKNOWN,255). + +-define(DEFLATE_INIT, 1). +-define(DEFLATE_INIT2, 2). +-define(DEFLATE_SETDICT, 3). +-define(DEFLATE_RESET, 4). +-define(DEFLATE_END, 5). +-define(DEFLATE_PARAMS, 6). +-define(DEFLATE, 7). + +-define(INFLATE_INIT, 8). +-define(INFLATE_INIT2, 9). +-define(INFLATE_SETDICT, 10). +-define(INFLATE_SYNC, 11). +-define(INFLATE_RESET, 12). +-define(INFLATE_END, 13). +-define(INFLATE, 14). + +-define(CRC32_0, 15). +-define(CRC32_1, 16). +-define(CRC32_2, 17). + +-define(SET_BUFSZ, 18). +-define(GET_BUFSZ, 19). +-define(GET_QSIZE, 20). + +-define(ADLER32_1, 21). +-define(ADLER32_2, 22). + +-define(CRC32_COMBINE, 23). +-define(ADLER32_COMBINE, 24). + +%%------------------------------------------------------------------------ + +%% Main data types of the file +-type(iodata() :: iolist() | binary()). %XXX To be removed in R13B. +-type zstream() :: port(). + +%% Auxiliary data types of the file +-type zlevel() :: 'none' | 'default' | 'best_compression' | 'best_speed' + | 0..9. +-type zmethod() :: 'deflated'. +-type zwindowbits() :: -15..-9 | 9..47. +-type zmemlevel() :: 1..9. +-type zstrategy() :: 'default' | 'filtered' | 'huffman_only'. +-type zflush() :: 'none' | 'sync' | 'full' | 'finish'. + +%%------------------------------------------------------------------------ + +%% open a z_stream +-spec open() -> zstream(). +open() -> + open_port({spawn, "zlib_drv"}, [binary]). + +%% close and release z_stream +-spec close(zstream()) -> 'ok'. +close(Z) -> + try + true = port_close(Z), + receive %In case the caller is the owner and traps exits + {'EXIT',Z,_} -> ok + after 0 -> ok + end + catch _:_ -> erlang:error(badarg) + end. + +-spec deflateInit(zstream()) -> 'ok'. +deflateInit(Z) -> + call(Z, ?DEFLATE_INIT, <<?Z_DEFAULT_COMPRESSION:32>>). + +-spec deflateInit(zstream(), zlevel()) -> 'ok'. +deflateInit(Z, Level) -> + call(Z, ?DEFLATE_INIT, <<(arg_level(Level)):32>>). + +-spec deflateInit(zstream(), zlevel(), zmethod(), + zwindowbits(), zmemlevel(), zstrategy()) -> 'ok'. +deflateInit(Z, Level, Method, WindowBits, MemLevel, Strategy) -> + call(Z, ?DEFLATE_INIT2, <<(arg_level(Level)):32, + (arg_method(Method)):32, + (arg_bitsz(WindowBits)):32, + (arg_mem(MemLevel)):32, + (arg_strategy(Strategy)):32>>). + +-spec deflateSetDictionary(zstream(), binary()) -> integer(). +deflateSetDictionary(Z, Dictionary) -> + call(Z, ?DEFLATE_SETDICT, Dictionary). + +-spec deflateReset(zstream()) -> 'ok'. +deflateReset(Z) -> + call(Z, ?DEFLATE_RESET, []). + +-spec deflateParams(zstream(), zlevel(), zstrategy()) -> 'ok'. +deflateParams(Z, Level, Strategy) -> + call(Z, ?DEFLATE_PARAMS, <<(arg_level(Level)):32, + (arg_strategy(Strategy)):32>>). + +-spec deflate(zstream(), iodata()) -> iolist(). +deflate(Z, Data) -> + deflate(Z, Data, none). + +-spec deflate(zstream(), iodata(), zflush()) -> iolist(). +deflate(Z, Data, Flush) -> + try port_command(Z, Data) of + true -> + call(Z, ?DEFLATE, <<(arg_flush(Flush)):32>>), + collect(Z) + catch + error:_Err -> + flush(Z), + erlang:error(badarg) + end. + +-spec deflateEnd(zstream()) -> 'ok'. +deflateEnd(Z) -> + call(Z, ?DEFLATE_END, []). + +-spec inflateInit(zstream()) -> 'ok'. +inflateInit(Z) -> + call(Z, ?INFLATE_INIT, []). + +-spec inflateInit(zstream(), zwindowbits()) -> 'ok'. +inflateInit(Z, WindowBits) -> + call(Z, ?INFLATE_INIT2, <<(arg_bitsz(WindowBits)):32>>). + +-spec inflateSetDictionary(zstream(), binary()) -> 'ok'. +inflateSetDictionary(Z, Dictionary) -> + call(Z, ?INFLATE_SETDICT, Dictionary). + +-spec inflateSync(zstream()) -> 'ok'. +inflateSync(Z) -> + call(Z, ?INFLATE_SYNC, []). + +-spec inflateReset(zstream()) -> 'ok'. +inflateReset(Z) -> + call(Z, ?INFLATE_RESET, []). + +-spec inflate(zstream(), iodata()) -> iolist(). +inflate(Z, Data) -> + try port_command(Z, Data) of + true -> + call(Z, ?INFLATE, <<?Z_NO_FLUSH:32>>), + collect(Z) + catch + error:_Err -> + flush(Z), + erlang:error(badarg) + end. + +-spec inflateEnd(zstream()) -> 'ok'. +inflateEnd(Z) -> + call(Z, ?INFLATE_END, []). + +-spec setBufSize(zstream(), non_neg_integer()) -> 'ok'. +setBufSize(Z, Size) -> + call(Z, ?SET_BUFSZ, <<Size:32>>). + +-spec getBufSize(zstream()) -> non_neg_integer(). +getBufSize(Z) -> + call(Z, ?GET_BUFSZ, []). + +-spec crc32(zstream()) -> integer(). +crc32(Z) -> + call(Z, ?CRC32_0, []). + +-spec crc32(zstream(), binary()) -> integer(). +crc32(Z, Binary) -> + call(Z, ?CRC32_1, Binary). + +-spec crc32(zstream(), integer(), binary()) -> integer(). +crc32(Z, CRC, Binary) when is_binary(Binary), is_integer(CRC) -> + call(Z, ?CRC32_2, <<CRC:32, Binary/binary>>); +crc32(_Z, _CRC, _Binary) -> + erlang:error(badarg). + +-spec adler32(zstream(), binary()) -> integer(). +adler32(Z, Binary) -> + call(Z, ?ADLER32_1, Binary). + +-spec adler32(zstream(), integer(), binary()) -> integer(). +adler32(Z, Adler, Binary) when is_binary(Binary), is_integer(Adler) -> + call(Z, ?ADLER32_2, <<Adler:32, Binary/binary>>); +adler32(_Z, _Adler, _Binary) -> + erlang:error(badarg). + +-spec crc32_combine(zstream(), integer(), integer(), integer()) -> integer(). +crc32_combine(Z, CRC1, CRC2, Len2) + when is_integer(CRC1), is_integer(CRC2), is_integer(Len2) -> + call(Z, ?CRC32_COMBINE, <<CRC1:32, CRC2:32, Len2:32>>); +crc32_combine(_Z, _CRC1, _CRC2, _Len2) -> + erlang:error(badarg). + +-spec adler32_combine(zstream(), integer(), integer(), integer()) -> integer(). +adler32_combine(Z, Adler1, Adler2, Len2) + when is_integer(Adler1), is_integer(Adler2), is_integer(Len2) -> + call(Z, ?ADLER32_COMBINE, <<Adler1:32, Adler2:32, Len2:32>>); +adler32_combine(_Z, _Adler1, _Adler2, _Len2) -> + erlang:error(badarg). + +-spec getQSize(zstream()) -> non_neg_integer(). +getQSize(Z) -> + call(Z, ?GET_QSIZE, []). + +%% compress/uncompress zlib with header +-spec compress(binary()) -> binary(). +compress(Binary) -> + Z = open(), + deflateInit(Z, default), + Bs = deflate(Z, Binary,finish), + deflateEnd(Z), + close(Z), + list_to_binary(Bs). + +-spec uncompress(binary()) -> binary(). +uncompress(Binary) when byte_size(Binary) >= 8 -> + Z = open(), + inflateInit(Z), + Bs = inflate(Z, Binary), + inflateEnd(Z), + close(Z), + list_to_binary(Bs); +uncompress(Binary) when is_binary(Binary) -> erlang:error(data_error); +uncompress(_) -> erlang:error(badarg). + +%% unzip/zip zlib without header (zip members) +-spec zip(binary()) -> binary(). +zip(Binary) -> + Z = open(), + deflateInit(Z, default, deflated, -?MAX_WBITS, 8, default), + Bs = deflate(Z, Binary, finish), + deflateEnd(Z), + close(Z), + list_to_binary(Bs). + +-spec unzip(binary()) -> binary(). +unzip(Binary) -> + Z = open(), + inflateInit(Z, -?MAX_WBITS), + Bs = inflate(Z, Binary), + inflateEnd(Z), + close(Z), + list_to_binary(Bs). + +-spec gzip(iodata()) -> binary(). +gzip(Data) when is_binary(Data); is_list(Data) -> + Z = open(), + deflateInit(Z, default, deflated, 16+?MAX_WBITS, 8, default), + Bs = deflate(Z, Data, finish), + deflateEnd(Z), + close(Z), + iolist_to_binary(Bs); +gzip(_) -> erlang:error(badarg). + +-spec gunzip(iodata()) -> binary(). +gunzip(Data) when is_binary(Data); is_list(Data) -> + Z = open(), + inflateInit(Z, 16+?MAX_WBITS), + Bs = inflate(Z, Data), + inflateEnd(Z), + close(Z), + iolist_to_binary(Bs); +gunzip(_) -> erlang:error(badarg). + +-spec collect(zstream()) -> iolist(). +collect(Z) -> + collect(Z, []). + +-spec collect(zstream(), iolist()) -> iolist(). +collect(Z, Acc) -> + receive + {Z, {data, Bin}} -> + collect(Z, [Bin|Acc]) + after 0 -> + reverse(Acc) + end. + +-spec flush(zstream()) -> 'ok'. +flush(Z) -> + receive + {Z, {data,_}} -> + flush(Z) + after 0 -> + ok + end. + +arg_flush(none) -> ?Z_NO_FLUSH; +%% ?Z_PARTIAL_FLUSH is deprecated in zlib -- deliberately not included. +arg_flush(sync) -> ?Z_SYNC_FLUSH; +arg_flush(full) -> ?Z_FULL_FLUSH; +arg_flush(finish) -> ?Z_FINISH; +arg_flush(_) -> erlang:error(badarg). + +arg_level(none) -> ?Z_NO_COMPRESSION; +arg_level(best_speed) -> ?Z_BEST_SPEED; +arg_level(best_compression) -> ?Z_BEST_COMPRESSION; +arg_level(default) -> ?Z_DEFAULT_COMPRESSION; +arg_level(Level) when is_integer(Level), Level >= 0, Level =< 9 -> Level; +arg_level(_) -> erlang:error(badarg). + +arg_strategy(filtered) -> ?Z_FILTERED; +arg_strategy(huffman_only) -> ?Z_HUFFMAN_ONLY; +arg_strategy(default) -> ?Z_DEFAULT_STRATEGY; +arg_strategy(_) -> erlang:error(badarg). + +arg_method(deflated) -> ?Z_DEFLATED; +arg_method(_) -> erlang:error(badarg). + +-spec arg_bitsz(zwindowbits()) -> zwindowbits(). +arg_bitsz(Bits) when is_integer(Bits) andalso + ((8 < Bits andalso Bits < 48) orelse + (-15 =< Bits andalso Bits < -8)) -> + Bits; +arg_bitsz(_) -> erlang:error(badarg). + +-spec arg_mem(zmemlevel()) -> zmemlevel(). +arg_mem(Level) when is_integer(Level), 1 =< Level, Level =< 9 -> Level; +arg_mem(_) -> erlang:error(badarg). + +call(Z, Cmd, Arg) -> + try port_control(Z, Cmd, Arg) of + [0|Res] -> list_to_atom(Res); + [1|Res] -> + flush(Z), + erlang:error(list_to_atom(Res)); + [2,A,B,C,D] -> + (A bsl 24)+(B bsl 16)+(C bsl 8)+D; + [3,A,B,C,D] -> + erlang:error({need_dictionary,(A bsl 24)+(B bsl 16)+(C bsl 8)+D}) + catch + error:badarg -> %% Rethrow loses port_control from stacktrace. + erlang:error(badarg) + end. + +reverse(X) -> + reverse(X, []). + +reverse([H|T], Y) -> + reverse(T, [H|Y]); +reverse([], X) -> + X. |