diff options
Diffstat (limited to 'lib/stdlib/src')
87 files changed, 12566 insertions, 6754 deletions
diff --git a/lib/stdlib/src/Makefile b/lib/stdlib/src/Makefile index 9f4a446ea0..bf836203ec 100644 --- a/lib/stdlib/src/Makefile +++ b/lib/stdlib/src/Makefile @@ -1,7 +1,7 @@ # # %CopyrightBegin% # -# Copyright Ericsson AB 1996-2015. All Rights Reserved. +# Copyright Ericsson AB 1996-2017. All Rights Reserved. # # Licensed under the Apache License, Version 2.0 (the "License"); # you may not use this file except in compliance with the License. @@ -51,7 +51,6 @@ MODULES= \ dets_server \ dets_sup \ dets_utils \ - dets_v8 \ dets_v9 \ dict \ digraph \ @@ -59,6 +58,7 @@ MODULES= \ edlin \ edlin_expand \ epp \ + erl_abstract_code \ erl_anno \ erl_bits \ erl_compile \ @@ -85,6 +85,7 @@ MODULES= \ gen_event \ gen_fsm \ gen_server \ + gen_statem \ io \ io_lib \ io_lib_format \ @@ -119,6 +120,7 @@ MODULES= \ sys \ timer \ unicode \ + unicode_util \ win32reg \ zip @@ -130,7 +132,7 @@ HRL_FILES= \ ../include/qlc.hrl \ ../include/zip.hrl -INTERNAL_HRL_FILES= dets.hrl +INTERNAL_HRL_FILES= dets.hrl erl_tar.hrl ERL_FILES= $(MODULES:%=%.erl) @@ -200,6 +202,9 @@ $(APP_TARGET): $(APP_SRC) ../vsn.mk $(APPUP_TARGET): $(APPUP_SRC) ../vsn.mk $(vsn_verbose)sed -e 's;%VSN%;$(VSN);' $< > $@ +unicode_util.erl: ../uc_spec/* + escript ../uc_spec/gen_unicode_mod.escript + # ---------------------------------------------------- # Release Target # ---------------------------------------------------- @@ -224,12 +229,11 @@ $(EBIN)/beam_lib.beam: ../include/erl_compile.hrl ../../kernel/include/file.hrl $(EBIN)/dets.beam: dets.hrl ../../kernel/include/file.hrl $(EBIN)/dets_server.beam: dets.hrl $(EBIN)/dets_utils.beam: dets.hrl -$(EBIN)/dets_v8.beam: dets.hrl $(EBIN)/dets_v9.beam: dets.hrl $(EBIN)/erl_bits.beam: ../include/erl_bits.hrl $(EBIN)/erl_compile.beam: ../include/erl_compile.hrl ../../kernel/include/file.hrl $(EBIN)/erl_lint.beam: ../include/erl_bits.hrl -$(EBIN)/erl_tar.beam: ../../kernel/include/file.hrl +$(EBIN)/erl_tar.beam: ../../kernel/include/file.hrl erl_tar.hrl $(EBIN)/file_sorter.beam: ../../kernel/include/file.hrl $(EBIN)/filelib.beam: ../../kernel/include/file.hrl $(EBIN)/filename.beam: ../../kernel/include/file.hrl diff --git a/lib/stdlib/src/array.erl b/lib/stdlib/src/array.erl index c749dd008b..a237eaa489 100644 --- a/lib/stdlib/src/array.erl +++ b/lib/stdlib/src/array.erl @@ -1,8 +1,3 @@ -%% -%% %CopyrightBegin% -%% -%% Copyright Ericsson AB 2007-2014. All Rights Reserved. -%% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. %% You may obtain a copy of the License at @@ -14,13 +9,12 @@ %% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. %% See the License for the specific language governing permissions and %% limitations under the License. -%% -%% %CopyrightEnd% %% -%% @author Richard Carlsson <[email protected]> +%% Copyright (C) 2006-2016 Richard Carlsson and Ericsson AB +%% +%% @author Richard Carlsson <[email protected]> %% @author Dan Gudmundsson <[email protected]> -%% @version 1.0 - +%% %% @doc Functional, extendible arrays. Arrays can have fixed size, or %% can grow automatically as needed. A default value is used for entries %% that have not been explicitly set. @@ -1609,7 +1603,7 @@ foldl_2(I, E, A, Ix, F, D, N, R, S) -> Ix + S, F, D, N, R, S). -spec foldl_3(pos_integer(), _, A, array_indx(), - fun((array_indx, _, A) -> B), integer()) -> B. + fun((array_indx(), _, A) -> B), integer()) -> B. foldl_3(I, E, A, Ix, F, N) when I =< N -> foldl_3(I+1, E, F(Ix, element(I, E), A), Ix+1, F, N); diff --git a/lib/stdlib/src/base64.erl b/lib/stdlib/src/base64.erl index ac532f7ee0..5885745fb1 100644 --- a/lib/stdlib/src/base64.erl +++ b/lib/stdlib/src/base64.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2007-2013. All Rights Reserved. +%% Copyright Ericsson AB 2007-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -219,38 +219,49 @@ mime_decode_binary(Result, <<0:8,T/bits>>) -> mime_decode_binary(Result, T); mime_decode_binary(Result0, <<C:8,T/bits>>) -> case element(C, ?DECODE_MAP) of - Bits when is_integer(Bits) -> - mime_decode_binary(<<Result0/bits,Bits:6>>, T); - eq -> - case tail_contains_more(T, false) of - {<<>>, Eq} -> - %% No more valid data. - case bit_size(Result0) rem 8 of - 0 -> - %% '====' is not uncommon. - Result0; - 4 when Eq -> - %% enforce at least one more '=' only ignoring illegals and spacing - Split = byte_size(Result0) - 1, - <<Result:Split/bytes,_:4>> = Result0, - Result; - 2 -> - %% remove 2 bits - Split = byte_size(Result0) - 1, - <<Result:Split/bytes,_:2>> = Result0, - Result - end; - {More, _} -> - %% More valid data, skip the eq as invalid - mime_decode_binary(Result0, More) - end; - _ -> - mime_decode_binary(Result0, T) + Bits when is_integer(Bits) -> + mime_decode_binary(<<Result0/bits,Bits:6>>, T); + eq -> + mime_decode_binary_after_eq(Result0, T, false); + _ -> + mime_decode_binary(Result0, T) end; -mime_decode_binary(Result, <<>>) -> +mime_decode_binary(Result, _) -> true = is_binary(Result), Result. +mime_decode_binary_after_eq(Result, <<0:8,T/bits>>, Eq) -> + mime_decode_binary_after_eq(Result, T, Eq); +mime_decode_binary_after_eq(Result0, <<C:8,T/bits>>, Eq) -> + case element(C, ?DECODE_MAP) of + bad -> + mime_decode_binary_after_eq(Result0, T, Eq); + ws -> + mime_decode_binary_after_eq(Result0, T, Eq); + eq -> + mime_decode_binary_after_eq(Result0, T, true); + Bits when is_integer(Bits) -> + %% More valid data, skip the eq as invalid + mime_decode_binary(<<Result0/bits,Bits:6>>, T) + end; +mime_decode_binary_after_eq(Result0, <<>>, Eq) -> + %% No more valid data. + case bit_size(Result0) rem 8 of + 0 -> + %% '====' is not uncommon. + Result0; + 4 when Eq -> + %% enforce at least one more '=' only ignoring illegals and spacing + Split = byte_size(Result0) - 1, + <<Result:Split/bytes,_:4>> = Result0, + Result; + 2 -> + %% remove 2 bits + Split = byte_size(Result0) - 1, + <<Result:Split/bytes,_:2>> = Result0, + Result + end. + decode([], A) -> A; decode([$=,$=,C2,C1|Cs], A) -> Bits2x6 = (b64d(C1) bsl 18) bor (b64d(C2) bsl 12), diff --git a/lib/stdlib/src/beam_lib.erl b/lib/stdlib/src/beam_lib.erl index b93ce97cd3..06c15fceda 100644 --- a/lib/stdlib/src/beam_lib.erl +++ b/lib/stdlib/src/beam_lib.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2000-2015. All Rights Reserved. +%% Copyright Ericsson AB 2000-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -46,7 +46,7 @@ terminate/2,code_change/3]). -export([make_crypto_key/2, get_crypto_key/1]). %Utilities used by compiler --export_type([attrib_entry/0, compinfo_entry/0, labeled_entry/0]). +-export_type([attrib_entry/0, compinfo_entry/0, labeled_entry/0, label/0]). -import(lists, [append/1, delete/2, foreach/2, keysort/2, member/2, reverse/1, sort/1, splitwith/2]). @@ -54,8 +54,9 @@ %%------------------------------------------------------------------------- -type beam() :: module() | file:filename() | binary(). +-type debug_info() :: {DbgiVersion :: atom(), Backend :: module(), Data :: term()} | 'no_debug_info'. --type forms() :: [erl_parse:abstract_form()]. +-type forms() :: [erl_parse:abstract_form() | erl_parse:form_info()]. -type abst_code() :: {AbstVersion :: atom(), forms()} | 'no_abstract_code'. -type dataB() :: binary(). @@ -63,8 +64,9 @@ -type label() :: integer(). -type chunkid() :: nonempty_string(). % approximation of the strings below -%% "Abst" | "Attr" | "CInf" | "ExpT" | "ImpT" | "LocT" | "Atom". --type chunkname() :: 'abstract_code' | 'attributes' | 'compile_info' +%% "Abst" | "Dbgi" | "Attr" | "CInf" | "ExpT" | "ImpT" | "LocT" | "Atom" | "AtU8". +-type chunkname() :: 'abstract_code' | 'debug_info' + | 'attributes' | 'compile_info' | 'exports' | 'labeled_exports' | 'imports' | 'indexed_imports' | 'locals' | 'labeled_locals' @@ -77,6 +79,7 @@ -type chunkdata() :: {chunkid(), dataB()} | {'abstract_code', abst_code()} + | {'debug_info', debug_info()} | {'attributes', [attrib_entry()]} | {'compile_info', [compinfo_entry()]} | {'exports', [{atom(), arity()}]} @@ -99,7 +102,7 @@ | {'file_error', file:filename(), file:posix()}. -type chnk_rsn() :: {'unknown_chunk', file:filename(), atom()} | {'key_missing_or_invalid', file:filename(), - 'abstract_code'} + 'abstract_code' | 'debug_info'} | info_rsn(). -type cmp_rsn() :: {'modules_different', module(), module()} | {'chunks_different', chunkid()} @@ -267,9 +270,9 @@ format_error({modules_different, Module1, Module2}) -> [Module1, Module2]); format_error({not_a_directory, Name}) -> io_lib:format("~tp: Not a directory~n", [Name]); -format_error({key_missing_or_invalid, File, abstract_code}) -> - io_lib:format("~tp: Cannot decrypt abstract code because key is missing or invalid", - [File]); +format_error({key_missing_or_invalid, File, ChunkId}) -> + io_lib:format("~tp: Cannot decrypt ~ts because key is missing or invalid", + [File, ChunkId]); format_error(badfun) -> "not a fun or the fun has the wrong arity"; format_error(exists) -> @@ -308,6 +311,17 @@ make_crypto_key(des3_cbc=Type, String) -> <<K3:8/binary,IVec:8/binary>> = erlang:md5([First|reverse(String)]), {Type,[K1,K2,K3],IVec,8}. +-spec build_module(Chunks) -> {'ok', Binary} when + Chunks :: [{chunkid(), dataB()}], + Binary :: binary(). + +build_module(Chunks0) -> + Chunks = list_to_binary(build_chunks(Chunks0)), + Size = byte_size(Chunks), + 0 = Size rem 4, % Assertion: correct padding? + {ok, <<"FOR1", (Size+4):32, "BEAM", Chunks/binary>>}. + + %% %% Local functions %% @@ -419,12 +433,6 @@ strip_file(File) -> end end. -build_module(Chunks0) -> - Chunks = list_to_binary(build_chunks(Chunks0)), - Size = byte_size(Chunks), - 0 = Size rem 4, % Assertion: correct padding? - {ok, <<"FOR1", (Size+4):32, "BEAM", Chunks/binary>>}. - build_chunks([{Id, Data} | Chunks]) -> BId = list_to_binary(Id), Size = byte_size(Data), @@ -505,9 +513,9 @@ read_chunk_data(File0, ChunkNames) -> read_chunk_data(File0, ChunkNames0, Options) when is_atom(File0); is_list(File0); is_binary(File0) -> File = beam_filename(File0), - {ChunkIds, Names} = check_chunks(ChunkNames0, File, [], []), + {ChunkIds, Names, Optional} = check_chunks(ChunkNames0, File, [], [], []), AllowMissingChunks = member(allow_missing_chunks, Options), - {ok, Module, Chunks} = scan_beam(File, ChunkIds, AllowMissingChunks), + {ok, Module, Chunks} = scan_beam(File, ChunkIds, AllowMissingChunks, Optional), AT = ets:new(beam_symbols, []), T = {empty, AT}, try chunks_to_data(Names, Chunks, File, Chunks, Module, T, []) @@ -515,25 +523,34 @@ read_chunk_data(File0, ChunkNames0, Options) end. %% -> {ok, list()} | throw(Error) -check_chunks([ChunkName | Ids], File, IL, L) when is_atom(ChunkName) -> +check_chunks([atoms | Ids], File, IL, L, O) -> + check_chunks(Ids, File, ["Atom", "AtU8" | IL], + [{atom_chunk, atoms} | L], ["Atom", "AtU8" | O]); +check_chunks([abstract_code | Ids], File, IL, L, O) -> + check_chunks(Ids, File, ["Abst", "Dbgi" | IL], + [{abst_chunk, abstract_code} | L], ["Abst", "Dbgi" | O]); +check_chunks([ChunkName | Ids], File, IL, L, O) when is_atom(ChunkName) -> ChunkId = chunk_name_to_id(ChunkName, File), - check_chunks(Ids, File, [ChunkId | IL], [{ChunkId, ChunkName} | L]); -check_chunks([ChunkId | Ids], File, IL, L) -> % when is_list(ChunkId) - check_chunks(Ids, File, [ChunkId | IL], [{ChunkId, ChunkId} | L]); -check_chunks([], _File, IL, L) -> - {lists:usort(IL), reverse(L)}. + check_chunks(Ids, File, [ChunkId | IL], [{ChunkId, ChunkName} | L], O); +check_chunks([ChunkId | Ids], File, IL, L, O) -> % when is_list(ChunkId) + check_chunks(Ids, File, [ChunkId | IL], [{ChunkId, ChunkId} | L], O); +check_chunks([], _File, IL, L, O) -> + {lists:usort(IL), reverse(L), O}. %% -> {ok, Module, Data} | throw(Error) scan_beam(File, What) -> - scan_beam(File, What, false). + scan_beam(File, What, false, []). %% -> {ok, Module, Data} | throw(Error) -scan_beam(File, What0, AllowMissingChunks) -> +scan_beam(File, What0, AllowMissingChunks, OptionalChunks) -> case scan_beam1(File, What0) of {missing, _FD, Mod, Data, What} when AllowMissingChunks -> {ok, Mod, [{Id, missing_chunk} || Id <- What] ++ Data}; - {missing, FD, _Mod, _Data, What} -> - error({missing_chunk, filename(FD), hd(What)}); + {missing, FD, Mod, Data, What} -> + case What -- OptionalChunks of + [] -> {ok, Mod, Data}; + [Missing | _] -> error({missing_chunk, filename(FD), Missing}) + end; R -> R end. @@ -576,18 +593,23 @@ scan_beam(FD, Pos, What, Mod, Data) -> error({invalid_beam_file, filename(FD), Pos}) end. -get_data(Cs, "Atom"=Id, FD, Size, Pos, Pos2, _Mod, Data) -> +get_atom_data(Cs, Id, FD, Size, Pos, Pos2, Data, Encoding) -> NewCs = del_chunk(Id, Cs), {NFD, Chunk} = get_chunk(Id, Pos, Size, FD), <<_Num:32, Chunk2/binary>> = Chunk, - {Module, _} = extract_atom(Chunk2), + {Module, _} = extract_atom(Chunk2, Encoding), C = case Cs of info -> {Id, Pos, Size}; _ -> {Id, Chunk} end, - scan_beam(NFD, Pos2, NewCs, Module, [C | Data]); + scan_beam(NFD, Pos2, NewCs, Module, [C | Data]). + +get_data(Cs, "Atom" = Id, FD, Size, Pos, Pos2, _Mod, Data) -> + get_atom_data(Cs, Id, FD, Size, Pos, Pos2, Data, latin1); +get_data(Cs, "AtU8" = Id, FD, Size, Pos, Pos2, _Mod, Data) -> + get_atom_data(Cs, Id, FD, Size, Pos, Pos2, Data, utf8); get_data(info, Id, FD, Size, Pos, Pos2, Mod, Data) -> scan_beam(FD, Pos2, info, Mod, [{Id, Pos, Size} | Data]); get_data(Chunks, Id, FD, Size, Pos, Pos2, Mod, Data) -> @@ -619,6 +641,25 @@ get_chunk(Id, Pos, Size, FD) -> {NFD, Chunk} end. +chunks_to_data([{atom_chunk, Name} | CNs], Chunks, File, Cs, Module, Atoms, L) -> + {NewAtoms, Ret} = chunk_to_data(Name, <<"">>, File, Cs, Atoms, Module), + chunks_to_data(CNs, Chunks, File, Cs, Module, NewAtoms, [Ret | L]); +chunks_to_data([{abst_chunk, Name} | CNs], Chunks, File, Cs, Module, Atoms, L) -> + DbgiChunk = proplists:get_value("Dbgi", Chunks, <<"">>), + {NewAtoms, Ret} = + case catch chunk_to_data(debug_info, DbgiChunk, File, Cs, Atoms, Module) of + {DbgiAtoms, {debug_info, {debug_info_v1, Backend, Metadata}}} -> + case Backend:debug_info(erlang_v1, Module, Metadata, []) of + {ok, Code} -> {DbgiAtoms, {abstract_code, {raw_abstract_v1, Code}}}; + {error, _} -> {DbgiAtoms, {abstract_code, no_abstract_code}} + end; + {error,beam_lib,{key_missing_or_invalid,Path,debug_info}} -> + error({key_missing_or_invalid,Path,abstract_code}); + _ -> + AbstChunk = proplists:get_value("Abst", Chunks, <<"">>), + chunk_to_data(Name, AbstChunk, File, Cs, Atoms, Module) + end, + chunks_to_data(CNs, Chunks, File, Cs, Module, NewAtoms, [Ret | L]); chunks_to_data([{Id, Name} | CNs], Chunks, File, Cs, Module, Atoms, L) -> {_Id, Chunk} = lists:keyfind(Id, 1, Chunks), {NewAtoms, Ret} = chunk_to_data(Name, Chunk, File, Cs, Atoms, Module), @@ -641,13 +682,30 @@ chunk_to_data(compile_info=Id, Chunk, File, _Cs, AtomTable, _Mod) -> error:badarg -> error({invalid_chunk, File, chunk_name_to_id(Id, File)}) end; +chunk_to_data(debug_info=Id, Chunk, File, _Cs, AtomTable, Mod) -> + case Chunk of + <<>> -> + {AtomTable, {Id, no_debug_info}}; + <<0:8,N:8,Mode0:N/binary,Rest/binary>> -> + Mode = binary_to_atom(Mode0, utf8), + Term = decrypt_chunk(Mode, Mod, File, Id, Rest), + {AtomTable, {Id, Term}}; + _ -> + case catch binary_to_term(Chunk) of + {'EXIT', _} -> + error({invalid_chunk, File, chunk_name_to_id(Id, File)}); + Term -> + {AtomTable, {Id, Term}} + end + end; chunk_to_data(abstract_code=Id, Chunk, File, _Cs, AtomTable, Mod) -> case Chunk of <<>> -> {AtomTable, {Id, no_abstract_code}}; <<0:8,N:8,Mode0:N/binary,Rest/binary>> -> - Mode = list_to_atom(binary_to_list(Mode0)), - decrypt_abst(Mode, Mod, File, Id, AtomTable, Rest); + Mode = binary_to_atom(Mode0, utf8), + Term = decrypt_chunk(Mode, Mod, File, Id, Rest), + {AtomTable, {Id, anno_from_term(Term)}}; _ -> case catch binary_to_term(Chunk) of {'EXIT', _} -> @@ -678,7 +736,6 @@ chunk_to_data(ChunkId, Chunk, _File, _Cs, AtomTable, _Module) when is_list(ChunkId) -> {AtomTable, {ChunkId, Chunk}}. % Chunk is a binary -chunk_name_to_id(atoms, _) -> "Atom"; chunk_name_to_id(indexed_imports, _) -> "ImpT"; chunk_name_to_id(imports, _) -> "ImpT"; chunk_name_to_id(exports, _) -> "ExpT"; @@ -687,6 +744,7 @@ chunk_name_to_id(locals, _) -> "LocT"; chunk_name_to_id(labeled_locals, _) -> "LocT"; chunk_name_to_id(attributes, _) -> "Attr"; chunk_name_to_id(abstract_code, _) -> "Abst"; +chunk_name_to_id(debug_info, _) -> "Dbgi"; chunk_name_to_id(compile_info, _) -> "CInf"; chunk_name_to_id(Other, File) -> error({unknown_chunk, File, Other}). @@ -733,25 +791,30 @@ atm(AT, N) -> %% AT is updated. ensure_atoms({empty, AT}, Cs) -> - {_Id, AtomChunk} = lists:keyfind("Atom", 1, Cs), - extract_atoms(AtomChunk, AT), + case lists:keyfind("AtU8", 1, Cs) of + {_Id, AtomChunk} when is_binary(AtomChunk) -> + extract_atoms(AtomChunk, AT, utf8); + _ -> + {_Id, AtomChunk} = lists:keyfind("Atom", 1, Cs), + extract_atoms(AtomChunk, AT, latin1) + end, AT; ensure_atoms(AT, _Cs) -> AT. -extract_atoms(<<_Num:32, B/binary>>, AT) -> - extract_atoms(B, 1, AT). +extract_atoms(<<_Num:32, B/binary>>, AT, Encoding) -> + extract_atoms(B, 1, AT, Encoding). -extract_atoms(<<>>, _I, _AT) -> +extract_atoms(<<>>, _I, _AT, _Encoding) -> true; -extract_atoms(B, I, AT) -> - {Atom, B1} = extract_atom(B), +extract_atoms(B, I, AT, Encoding) -> + {Atom, B1} = extract_atom(B, Encoding), true = ets:insert(AT, {I, Atom}), - extract_atoms(B1, I+1, AT). + extract_atoms(B1, I+1, AT, Encoding). -extract_atom(<<Len, B/binary>>) -> +extract_atom(<<Len, B/binary>>, Encoding) -> <<SB:Len/binary, Tail/binary>> = B, - {list_to_atom(binary_to_list(SB)), Tail}. + {binary_to_atom(SB, Encoding), Tail}. %%% Utils. @@ -851,12 +914,12 @@ significant_chunks() -> %% for a module. They are listed in the order that they should be MD5:ed. md5_chunks() -> - ["Atom", "Code", "StrT", "ImpT", "ExpT", "FunT", "LitT"]. + ["Atom", "AtU8", "Code", "StrT", "ImpT", "ExpT", "FunT", "LitT"]. %% The following chunks are mandatory in every Beam file. mandatory_chunks() -> - ["Code", "ExpT", "ImpT", "StrT", "Atom"]. + ["Code", "ExpT", "ImpT", "StrT"]. %%% ==================================================================== %%% The rest of the file handles encrypted debug info. @@ -867,27 +930,22 @@ mandatory_chunks() -> %%% can use it. %%% ==================================================================== --record(state, {crypto_key_f :: crypto_fun()}). +-record(state, {crypto_key_f :: crypto_fun() | 'undefined'}). -define(CRYPTO_KEY_SERVER, beam_lib__crypto_key_server). -decrypt_abst(Type, Module, File, Id, AtomTable, Bin) -> +decrypt_chunk(Type, Module, File, Id, Bin) -> try KeyString = get_crypto_key({debug_info, Type, Module, File}), - Key = make_crypto_key(Type, KeyString), - Term = decrypt_abst_1(Key, Bin), - {AtomTable, {Id, Term}} + {Type,Key,IVec,_BlockSize} = make_crypto_key(Type, KeyString), + ok = start_crypto(), + NewBin = crypto:block_decrypt(Type, Key, IVec, Bin), + binary_to_term(NewBin) catch _:_ -> error({key_missing_or_invalid, File, Id}) end. -decrypt_abst_1({Type,Key,IVec,_BlockSize}, Bin) -> - ok = start_crypto(), - NewBin = crypto:block_decrypt(Type, Key, IVec, Bin), - Term = binary_to_term(NewBin), - anno_from_term(Term). - anno_from_term({raw_abstract_v1, Forms}) -> {raw_abstract_v1, anno_from_forms(Forms)}; anno_from_term({Tag, Forms}) when Tag =:= abstract_v1; Tag =:= abstract_v2 -> @@ -899,7 +957,11 @@ anno_from_term({Tag, Forms}) when Tag =:= abstract_v1; Tag =:= abstract_v2 -> anno_from_term(T) -> T. -anno_from_forms(Forms) -> +anno_from_forms(Forms0) -> + %% Forms with record field types created before OTP 19.0 are + %% replaced by well-formed record forms holding the type + %% information. + Forms = epp:restore_typed_record_fields(Forms0), [erl_parse:anno_from_term(Form) || Form <- Forms]. start_crypto() -> @@ -926,7 +988,10 @@ call_crypto_server(Req) -> end. call_crypto_server_1(Req) -> - {ok, _} = gen_server:start({local,?CRYPTO_KEY_SERVER}, ?MODULE, [], []), + case gen_server:start({local,?CRYPTO_KEY_SERVER}, ?MODULE, [], []) of + {ok, _} -> ok; + {error, {already_started, _}} -> ok + end, erlang:yield(), call_crypto_server(Req). @@ -967,9 +1032,7 @@ handle_call({get_crypto_key, What}, From, #state{crypto_key_f=F}=S) -> handle_call({crypto_key_fun, F}, {_,_} = From, S) -> case S#state.crypto_key_f of undefined -> - %% Don't allow tuple funs here. (They weren't allowed before, - %% so there is no reason to allow them now.) - if is_function(F), is_function(F, 1) -> + if is_function(F, 1) -> {Result, Fun, Reply} = case catch F(init) of ok -> diff --git a/lib/stdlib/src/binary.erl b/lib/stdlib/src/binary.erl index af00410572..6a64133b45 100644 --- a/lib/stdlib/src/binary.erl +++ b/lib/stdlib/src/binary.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2010-2013. All Rights Reserved. +%% Copyright Ericsson AB 2010-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -20,11 +20,11 @@ -module(binary). %% %% Implemented in this module: --export([split/2,split/3,replace/3,replace/4]). +-export([replace/3,replace/4]). -export_type([cp/0]). --opaque cp() :: {'am' | 'bm', binary()}. +-opaque cp() :: {'am' | 'bm', reference()}. -type part() :: {Start :: non_neg_integer(), Length :: integer()}. %%% BIFs. @@ -34,7 +34,8 @@ decode_unsigned/2, encode_unsigned/1, encode_unsigned/2, first/1, last/1, list_to_bin/1, longest_common_prefix/1, longest_common_suffix/1, match/2, match/3, matches/2, - matches/3, part/2, part/3, referenced_byte_size/1]). + matches/3, part/2, part/3, referenced_byte_size/1, + split/2, split/3]). -spec at(Subject, Pos) -> byte() when Subject :: binary(), @@ -198,19 +199,13 @@ part(_, _, _) -> referenced_byte_size(_) -> erlang:nif_error(undef). -%%% End of BIFs. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% split -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -spec split(Subject, Pattern) -> Parts when Subject :: binary(), Pattern :: binary() | [binary()] | cp(), Parts :: [binary()]. -split(H,N) -> - split(H,N,[]). +split(_, _) -> + erlang:nif_error(undef). -spec split(Subject, Pattern, Options) -> Parts when Subject :: binary(), @@ -219,53 +214,10 @@ split(H,N) -> Option :: {scope, part()} | trim | global | trim_all, Parts :: [binary()]. -split(Haystack,Needles,Options) -> - try - {Part,Global,Trim,TrimAll} = - get_opts_split(Options,{no,false,false,false}), - Moptlist = case Part of - no -> - []; - {A,B} -> - [{scope,{A,B}}] - end, - MList = if - Global -> - binary:matches(Haystack,Needles,Moptlist); - true -> - case binary:match(Haystack,Needles,Moptlist) of - nomatch -> []; - Match -> [Match] - end - end, - do_split(Haystack,MList,0,Trim,TrimAll) - catch - _:_ -> - erlang:error(badarg) - end. - -do_split(H,[],N,true,_) when N >= byte_size(H) -> - []; -do_split(H,[],N,_,true) when N >= byte_size(H) -> - []; -do_split(H,[],N,_,_) -> - [binary:part(H,{N,byte_size(H)-N})]; -do_split(H,[{A,B}|T],N,Trim,TrimAll) -> - case binary:part(H,{N,A-N}) of - <<>> when TrimAll == true -> - do_split(H,T,A+B,Trim,TrimAll); - <<>> -> - Rest = do_split(H,T,A+B,Trim,TrimAll), - case {Trim, Rest} of - {true,[]} -> - []; - _ -> - [<<>> | Rest] - end; - Oth -> - [Oth | do_split(H,T,A+B,Trim,TrimAll)] - end. +split(_, _, _) -> + erlang:nif_error(undef). +%%% End of BIFs. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% replace @@ -352,19 +304,6 @@ splitat(H,N,[I|T]) -> %% Simple helper functions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -get_opts_split([],{Part,Global,Trim,TrimAll}) -> - {Part,Global,Trim,TrimAll}; -get_opts_split([{scope,{A,B}} | T],{_Part,Global,Trim,TrimAll}) -> - get_opts_split(T,{{A,B},Global,Trim,TrimAll}); -get_opts_split([global | T],{Part,_Global,Trim,TrimAll}) -> - get_opts_split(T,{Part,true,Trim,TrimAll}); -get_opts_split([trim | T],{Part,Global,_Trim,TrimAll}) -> - get_opts_split(T,{Part,Global,true,TrimAll}); -get_opts_split([trim_all | T],{Part,Global,Trim,_TrimAll}) -> - get_opts_split(T,{Part,Global,Trim,true}); -get_opts_split(_,_) -> - throw(badopt). - get_opts_replace([],{Part,Global,Insert}) -> {Part,Global,Insert}; get_opts_replace([{scope,{A,B}} | T],{_Part,Global,Insert}) -> diff --git a/lib/stdlib/src/c.erl b/lib/stdlib/src/c.erl index a8844d757d..c04a201ce1 100644 --- a/lib/stdlib/src/c.erl +++ b/lib/stdlib/src/c.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2013. All Rights Reserved. +%% Copyright Ericsson AB 1996-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -23,10 +23,10 @@ %% Avoid warning for local function error/2 clashing with autoimported BIF. -compile({no_auto_import,[error/2]}). --export([help/0,lc/1,c/1,c/2,nc/1,nc/2, nl/1,l/1,i/0,i/1,ni/0, +-export([help/0,lc/1,c/1,c/2,c/3,nc/1,nc/2, nl/1,l/1,i/0,i/1,ni/0, y/1, y/2, lc_batch/0, lc_batch/1, - i/3,pid/3,m/0,m/1, + i/3,pid/3,m/0,m/1,mm/0,lm/0, bt/1, q/0, erlangrc/0,erlangrc/1,bi/1, flush/0, regs/0, uptime/0, nregs/0,pwd/0,ls/0,ls/1,cd/1,memory/1,memory/0, xm/1]). @@ -35,7 +35,7 @@ -export([appcall/4]). -import(lists, [reverse/1,flatten/1,sublist/3,sort/1,keysort/2, - concat/1,max/1,min/1,foreach/2,foldl/3,flatmap/2]). + max/1,min/1,foreach/2,foldl/3,flatmap/2]). -import(io, [format/1, format/2]). %%----------------------------------------------------------------------- @@ -44,7 +44,7 @@ help() -> io:put_chars(<<"bt(Pid) -- stack backtrace for a process\n" - "c(File) -- compile and load code in <File>\n" + "c(Mod) -- compile and load module or file <Mod>\n" "cd(Dir) -- change working directory\n" "flush() -- flush any messages sent to the shell\n" "help() -- help info\n" @@ -52,11 +52,13 @@ help() -> "ni() -- information about the networked system\n" "i(X,Y,Z) -- information about pid <X,Y,Z>\n" "l(Module) -- load or reload module\n" + "lm() -- load all modified modules\n" "lc([File]) -- compile a list of Erlang modules\n" "ls() -- list files in the current directory\n" "ls(Dir) -- list files in directory <Dir>\n" "m() -- which modules are loaded\n" "m(Mod) -- information about module <Mod>\n" + "mm() -- list all modified modules\n" "memory() -- memory allocation information\n" "memory(T) -- memory allocation information of type <T>\n" "nc(File) -- compile and load code in <File> on all nodes\n" @@ -70,32 +72,224 @@ help() -> "xm(M) -- cross reference check a module\n" "y(File) -- generate a Yecc parser\n">>). -%% c(FileName) -%% Compile a file/module. - --spec c(File) -> {'ok', Module} | 'error' when - File :: file:name(), - Module :: module(). +%% c(Module) +%% Compile a module/file. + +-spec c(Module) -> {'ok', ModuleName} | 'error' when + Module :: file:name(), + ModuleName :: module(). + +c(Module) -> c(Module, []). + +-spec c(Module, Options) -> {'ok', ModuleName} | 'error' when + Module :: file:name(), + Options :: [compile:option()] | compile:option(), + ModuleName :: module(). + +c(Module, SingleOption) when not is_list(SingleOption) -> + c(Module, [SingleOption]); +c(Module, Opts) when is_atom(Module) -> + %% either a module name or a source file name (possibly without + %% suffix); if such a source file exists, it is used to compile from + %% scratch with the given options, otherwise look for an object file + Suffix = case filename:extension(Module) of + "" -> src_suffix(Opts); + S -> S + end, + SrcFile = filename:rootname(Module, Suffix) ++ Suffix, + case filelib:is_file(SrcFile) of + true -> + compile_and_load(SrcFile, Opts); + false -> + c(Module, Opts, fun (_) -> true end) + end; +c(Module, Opts) -> + %% we never interpret a string as a module name, only as a file + compile_and_load(Module, Opts). -c(File) -> c(File, []). +%% This tries to find an existing object file and use its compile_info and +%% source path to recompile the module, overwriting the old object file. +%% The Filter parameter is applied to the old compile options --spec c(File, Options) -> {'ok', Module} | 'error' when - File :: file:name(), +-spec c(Module, Options, Filter) -> {'ok', ModuleName} | 'error' when + Module :: atom(), Options :: [compile:option()], - Module :: module(). + Filter :: fun ((compile:option()) -> boolean()), + ModuleName :: module(). + +c(Module, Options, Filter) when is_atom(Module) -> + case find_beam(Module) of + BeamFile when is_list(BeamFile) -> + c(Module, Options, Filter, BeamFile); + Error -> + {error, Error} + end. + +c(Module, Options, Filter, BeamFile) -> + case compile_info(Module, BeamFile) of + Info when is_list(Info) -> + case find_source(BeamFile, Info) of + SrcFile when is_list(SrcFile) -> + c(SrcFile, Options, Filter, BeamFile, Info); + Error -> + Error + end; + Error -> + Error + end. -c(File, Opts0) when is_list(Opts0) -> - Opts = [report_errors,report_warnings|Opts0], +c(SrcFile, NewOpts, Filter, BeamFile, Info) -> + %% Filter old options; also remove options that will be replaced. + %% Write new beam over old beam unless other outdir is specified. + F = fun (Opt) -> not is_outdir_opt(Opt) andalso Filter(Opt) end, + Options = (NewOpts ++ [{outdir,filename:dirname(BeamFile)}] + ++ lists:filter(F, old_options(Info))), + format("Recompiling ~ts\n", [SrcFile]), + safe_recompile(SrcFile, Options, BeamFile). + +old_options(Info) -> + case lists:keyfind(options, 1, Info) of + {options, Opts} -> Opts; + false -> [] + end. + +%% prefer the source path in the compile info if the file exists, +%% otherwise do a standard source search relative to the beam file +find_source(BeamFile, Info) -> + case lists:keyfind(source, 1, Info) of + {source, SrcFile} -> + case filelib:is_file(SrcFile) of + true -> SrcFile; + false -> find_source(BeamFile) + end; + _ -> + find_source(BeamFile) + end. + +find_source(BeamFile) -> + case filelib:find_source(BeamFile) of + {ok, SrcFile} -> SrcFile; + _ -> {error, no_source} + end. + +%% find the beam file for a module, preferring the path reported by code:which() +%% if it still exists, or otherwise by searching the code path +find_beam(Module) when is_atom(Module) -> + case code:which(Module) of + Beam when is_list(Beam), Beam =/= "" -> + case erlang:module_loaded(Module) of + false -> + Beam; % code:which/1 found this in the path + true -> + case filelib:is_file(Beam) of + true -> Beam; + false -> find_beam_1(Module) % file moved? + end + end; + Other when Other =:= ""; Other =:= cover_compiled -> + %% module is loaded but not compiled directly from source + find_beam_1(Module); + Error -> + Error + end. + +find_beam_1(Module) -> + File = atom_to_list(Module) ++ code:objfile_extension(), + case code:where_is_file(File) of + Beam when is_list(Beam) -> + Beam; + Error -> + Error + end. + +%% get the compile_info for a module +%% -will report the info for the module in memory, if loaded +%% -will try to find and examine the beam file if not in memory +%% -will not cause a module to become loaded by accident +compile_info(Module, Beam) when is_atom(Module) -> + case erlang:module_loaded(Module) of + true -> + %% getting the compile info for a loaded module should normally + %% work, but return an empty info list if it fails + try erlang:get_module_info(Module, compile) + catch _:_ -> [] + end; + false -> + case beam_lib:chunks(Beam, [compile_info]) of + {ok, {_Module, [{compile_info, Info}]}} -> + Info; + Error -> + Error + end + end. + +%% compile module, backing up any existing target file and restoring the +%% old version if compilation fails (this should only be used when we have +%% an old beam file that we want to preserve) +safe_recompile(File, Options, BeamFile) -> + %% Note that it's possible that because of options such as 'to_asm', + %% the compiler might not actually write a new beam file at all + Backup = BeamFile ++ ".bak", + case file:rename(BeamFile, Backup) of + Status when Status =:= ok; Status =:= {error,enoent} -> + case compile_and_load(File, Options) of + {ok, _} = Result -> + _ = if Status =:= ok -> file:delete(Backup); + true -> ok + end, + Result; + Error -> + _ = if Status =:= ok -> file:rename(Backup, BeamFile); + true -> ok + end, + Error + end; + Error -> + Error + end. + +%% Compile the file and load the resulting object code (if any). +%% Automatically ensures that there is an outdir option, by default the +%% directory of File, and that a 'from' option will be passed to match the +%% actual source suffix if needed (unless already specified). +compile_and_load(File, Opts0) when is_list(Opts0) -> + Opts = [report_errors, report_warnings + | ensure_from(filename:extension(File), + ensure_outdir(".", Opts0))], case compile:file(File, Opts) of {ok,Mod} -> %Listing file. - machine_load(Mod, File, Opts); + purge_and_load(Mod, File, Opts); {ok,Mod,_Ws} -> %Warnings maybe turned on. - machine_load(Mod, File, Opts); + purge_and_load(Mod, File, Opts); Other -> %Errors go here Other end; -c(File, Opt) -> - c(File, [Opt]). +compile_and_load(File, Opt) -> + compile_and_load(File, [Opt]). + +ensure_from(Suffix, Opts0) -> + case lists:partition(fun is_from_opt/1, Opts0++from_opt(Suffix)) of + {[Opt|_], Opts} -> [Opt | Opts]; + {[], Opts} -> Opts + end. + +ensure_outdir(Dir, Opts0) -> + {[Opt|_], Opts} = lists:partition(fun is_outdir_opt/1, + Opts0++[{outdir,Dir}]), + [Opt | Opts]. + +is_outdir_opt({outdir, _}) -> true; +is_outdir_opt(_) -> false. + +is_from_opt(from_core) -> true; +is_from_opt(from_asm) -> true; +is_from_opt(from_beam) -> true; +is_from_opt(_) -> false. + +from_opt(".core") -> [from_core]; +from_opt(".S") -> [from_asm]; +from_opt(".beam") -> [from_beam]; +from_opt(_) -> []. %%% Obtain the 'outdir' option from the argument. Return "." if no %%% such option was given. @@ -111,18 +305,29 @@ outdir([Opt|Rest]) -> outdir(Rest) end. +%% mimic how suffix is selected in compile:file(). +src_suffix([from_core|_]) -> ".core"; +src_suffix([from_asm|_]) -> ".S"; +src_suffix([from_beam|_]) -> ".beam"; +src_suffix([_|Opts]) -> src_suffix(Opts); +src_suffix([]) -> ".erl". + %%% We have compiled File with options Opts. Find out where the -%%% output file went to, and load it. -machine_load(Mod, File, Opts) -> +%%% output file went and load it, purging any old version. +purge_and_load(Mod, File, Opts) -> Dir = outdir(Opts), - File2 = filename:join(Dir, filename:basename(File, ".erl")), + Base = filename:basename(File, src_suffix(Opts)), + OutFile = filename:join(Dir, Base), case compile:output_generated(Opts) of true -> - Base = atom_to_list(Mod), - case filename:basename(File, ".erl") of + case atom_to_list(Mod) of Base -> code:purge(Mod), - check_load(code:load_abs(File2,Mod), Mod); + %% Note that load_abs() adds the object file suffix + case code:load_abs(OutFile, Mod) of + {error, _R}=Error -> Error; + _ -> {ok, Mod} + end; _OtherMod -> format("** Module name '~p' does not match file name '~tp' **~n", [Mod,File]), @@ -133,13 +338,6 @@ machine_load(Mod, File, Opts) -> ok end. -%%% This function previously warned if the loaded module was -%%% loaded from some other place than current directory. -%%% Now, loading from other than current directory is supposed to work. -%%% so this function does nothing special. -check_load({error, _R} = Error, _) -> Error; -check_load(_, Mod) -> {ok, Mod}. - %% Compile a list of modules %% enables the nice unix shell cmd %% erl -s c lc f1 f2 f3 @d c1=v1 @c2 @i IDir @o ODir -s erlang halt @@ -202,7 +400,7 @@ split_def([], Res) -> {d, list_to_atom(reverse(Res))}. make_term(Str) -> case erl_scan:string(Str) of {ok, Tokens, _} -> - case erl_parse:parse_term(Tokens ++ [{dot, 1}]) of + case erl_parse:parse_term(Tokens ++ [{dot, erl_anno:new(1)}]) of {ok, Term} -> Term; {error, {_,_,Reason}} -> io:format("~ts: ~ts~n", [Reason, Str]), @@ -350,7 +548,7 @@ mfa_string(Fun) when is_function(Fun) -> {arity,A} = erlang:fun_info(Fun, arity), mfa_string({M,F,A}); mfa_string({M,F,A}) -> - io_lib:format("~w:~w/~w", [M,F,A]); + io_lib:format("~w:~tw/~w", [M,F,A]); mfa_string(X) -> w(X). @@ -374,7 +572,7 @@ display_info(Pid) -> w(Reds), w(LM)), iformat(case fetch(registered_name, Info) of 0 -> ""; - X -> w(X) + X -> io_lib:format("~tw", [X]) end, mfa_string(Curr), w(SS), @@ -396,7 +594,7 @@ initial_call(Info) -> end. iformat(A1, A2, A3, A4, A5) -> - format("~-21s ~-33s ~8s ~8s ~4s~n", [A1,A2,A3,A4,A5]). + format("~-21ts ~-33ts ~8s ~8s ~4s~n", [A1,A2,A3,A4,A5]). all_procs() -> case is_alive() of @@ -459,6 +657,16 @@ m() -> mformat(A1, A2) -> format("~-20s ~ts\n", [A1,A2]). +-spec mm() -> [module()]. + +mm() -> + code:modified_modules(). + +-spec lm() -> [code:load_ret()]. + +lm() -> + [l(M) || M <- mm()]. + %% erlangrc(Home) %% Try to run a ".erlang" file, first in the current directory %% else in home directory. @@ -559,7 +767,7 @@ print_exports(X) when length(X) > 16 -> split_print_exports(X); print_exports([]) -> ok; print_exports([{F, A} |Tail]) -> - format(" ~w/~w~n",[F, A]), + format(" ~tw/~w~n",[F, A]), print_exports(Tail). split_print_exports(L) -> @@ -571,11 +779,11 @@ split_print_exports(L) -> split_print_exports([], [{F, A}|T]) -> Str = " ", - format("~-30s~w/~w~n", [Str, F, A]), + format("~-30ts~tw/~w~n", [Str, F, A]), split_print_exports([], T); split_print_exports([{F1, A1}|T1], [{F2, A2} | T2]) -> - Str = flatten(io_lib:format("~w/~w", [F1, A1])), - format("~-30s~w/~w~n", [Str, F2, A2]), + Str = flatten(io_lib:format("~tw/~w", [F1, A1])), + format("~-30ts~tw/~w~n", [Str, F2, A2]), split_print_exports(T1, T2); split_print_exports([], []) -> ok. @@ -675,22 +883,22 @@ procline(Name, Info, Pid) -> Call = initial_call(Info), Reds = fetch(reductions, Info), LM = length(fetch(messages, Info)), - procformat(io_lib:format("~w",[Name]), + procformat(io_lib:format("~tw",[Name]), io_lib:format("~w",[Pid]), - io_lib:format("~s",[mfa_string(Call)]), + io_lib:format("~ts",[mfa_string(Call)]), integer_to_list(Reds), integer_to_list(LM)). procformat(Name, Pid, Call, Reds, LM) -> - format("~-21s ~-12s ~-25s ~12s ~4s~n", [Name,Pid,Call,Reds,LM]). + format("~-21ts ~-12s ~-25ts ~12s ~4s~n", [Name,Pid,Call,Reds,LM]). portline(Name, Info, Id) -> Cmd = fetch(name, Info), - portformat(io_lib:format("~w",[Name]), + portformat(io_lib:format("~tw",[Name]), erlang:port_to_list(Id), Cmd). portformat(Name, Id, Cmd) -> - format("~-21s ~-15s ~-40s~n", [Name,Id,Cmd]). + format("~-21ts ~-15s ~-40ts~n", [Name,Id,Cmd]). %% pwd() %% cd(Directory) diff --git a/lib/stdlib/src/calendar.erl b/lib/stdlib/src/calendar.erl index 074c504e00..55a0cfc9a1 100644 --- a/lib/stdlib/src/calendar.erl +++ b/lib/stdlib/src/calendar.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2011. All Rights Reserved. +%% Copyright Ericsson AB 1996-2016. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. diff --git a/lib/stdlib/src/dets.erl b/lib/stdlib/src/dets.erl index 6d07f4018a..4e3fe0e5c1 100644 --- a/lib/stdlib/src/dets.erl +++ b/lib/stdlib/src/dets.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2014. All Rights Reserved. +%% Copyright Ericsson AB 1996-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -105,9 +105,6 @@ %%% the file with the split indicator, size etc is held in ram by the %%% server at all times. %%% -%%% The parts specific for formats up to and including 8(c) are -%%% implemented in dets_v8.erl, parts specific for format 9 are -%%% implemented in dets_v9.erl. %% The method of hashing is the so called linear hashing algorithm %% with segments. @@ -140,28 +137,33 @@ %%% written, and a repair is forced next time the file is opened. -record(dets_cont, { - what, % object | bindings | select | bchunk - no_objs, % requested number of objects: default | integer() > 0 - bin, % small chunk not consumed, or 'eof' at end-of-file - alloc, % the part of the file not yet scanned, mostly a binary - tab, - proc, % the pid of the Dets process - match_program % true | compiled_match_spec() | undefined + what :: 'undefined' | 'bchunk' | 'bindings' | 'object' | 'select', + no_objs :: 'default' | pos_integer(), % requested number of objects + bin :: 'eof' | binary(), % small chunk not consumed, + % or 'eof' at end-of-file + alloc :: binary() % the part of the file not yet scanned + | {From :: non_neg_integer(), + To :: non_neg_integer, + binary()}, + tab :: tab_name(), + proc :: 'undefined' | pid(), % the pid of the Dets process + match_program :: 'true' + | 'undefined' + | {'match_spec', ets:comp_match_spec()} }). -record(open_args, { - file, - type, - keypos, - repair, - min_no_slots, - max_no_slots, - ram_file, - delayed_write, - auto_save, - access, - version, - debug + file :: list(), + type :: type(), + keypos :: keypos(), + repair :: 'force' | boolean(), + min_no_slots :: no_slots(), + max_no_slots :: no_slots(), + ram_file :: boolean(), + delayed_write :: cache_parms(), + auto_save :: auto_save(), + access :: access(), + debug :: boolean() }). -define(PATTERN_TO_OBJECT_MATCH_SPEC(Pat), [{Pat,[],['$_']}]). @@ -177,20 +179,13 @@ %%-define(PROFILE(C), C). -define(PROFILE(C), void). --type access() :: 'read' | 'read_write'. --type auto_save() :: 'infinity' | non_neg_integer(). -opaque bindings_cont() :: #dets_cont{}. -opaque cont() :: #dets_cont{}. --type keypos() :: pos_integer(). -type match_spec() :: ets:match_spec(). -type object() :: tuple(). --type no_slots() :: non_neg_integer() | 'default'. -opaque object_cont() :: #dets_cont{}. -type pattern() :: atom() | tuple(). -opaque select_cont() :: #dets_cont{}. --type tab_name() :: term(). --type type() :: 'bag' | 'duplicate_bag' | 'set'. --type version() :: 8 | 9 | 'default'. %%% Some further debug code was added in R12B-1 (stdlib-1.15.1): %%% - there is a new open_file() option 'debug'; @@ -273,19 +268,20 @@ delete_all_objects(Tab) -> delete_object(Tab, O) -> badarg(treq(Tab, {delete_object, [O]}), [Tab, O]). +%% Backwards compatibility. +fsck(Fname, _Version) -> + fsck(Fname). + %% Given a filename, fsck it. Debug. fsck(Fname) -> - fsck(Fname, default). - -fsck(Fname, Version) -> catch begin {ok, Fd, FH} = read_file_header(Fname, read, false), ?DEBUGF("FileHeader: ~p~n", [FH]), - case (FH#fileheader.mod):check_file_header(FH, Fd) of + case dets_v9:check_file_header(FH, Fd) of {error, not_closed} -> - fsck(Fd, make_ref(), Fname, FH, default, default, Version); - {ok, _Head, _Extra} -> - fsck(Fd, make_ref(), Fname, FH, default, default, Version); + fsck(Fd, make_ref(), Fname, FH, default, default); + {ok, _Head} -> + fsck(Fd, make_ref(), Fname, FH, default, default); Error -> Error end @@ -372,7 +368,7 @@ info(Tab) -> Item :: 'access' | 'auto_save' | 'bchunk_format' | 'hash' | 'file_size' | 'filename' | 'keypos' | 'memory' | 'no_keys' | 'no_objects' | 'no_slots' | 'owner' | 'ram_file' - | 'safe_fixed' | 'size' | 'type' | 'version', + | 'safe_fixed' | 'safe_fixed_monotonic_time' | 'size' | 'type', Value :: term(). info(Tab, owner) -> @@ -640,8 +636,7 @@ open_file(File) -> | {'keypos', keypos()} | {'ram_file', boolean()} | {'repair', boolean() | 'force'} - | {'type', type()} - | {'version', version()}, + | {'type', type()}, Reason :: term(). open_file(Tab, Args) when is_list(Args) -> @@ -674,13 +669,13 @@ remove_user(Pid, From) -> Continuation2 :: select_cont(), MatchSpec :: match_spec(). -repair_continuation(#dets_cont{match_program = B}=Cont, MS) - when is_binary(B) -> +repair_continuation(#dets_cont{match_program = {match_spec, B}}=Cont, MS) -> case ets:is_compiled_ms(B) of true -> Cont; false -> - Cont#dets_cont{match_program = ets:match_spec_compile(MS)} + Cont#dets_cont{match_program = {match_spec, + ets:match_spec_compile(MS)}} end; repair_continuation(#dets_cont{}=Cont, _MS) -> Cont; @@ -999,7 +994,9 @@ init_chunk_match(Tab, Pat, What, N, Safe) when is_integer(N), N >= 0; case req(Proc, {match, MP, Spec, N, Safe}) of {done, L} -> {L, #dets_cont{tab = Tab, proc = Proc, - what = What, bin = eof}}; + what = What, bin = eof, + no_objs = default, + alloc = <<>>}}; {cont, State} -> chunk_match(State#dets_cont{what = What, tab = Tab, @@ -1041,17 +1038,17 @@ chunk_match(#dets_cont{proc = Proc}=State, Safe) -> do_foldl_bins(Bins, true) -> foldl_bins(Bins, []); -do_foldl_bins(Bins, MP) -> +do_foldl_bins(Bins, {match_spec, MP}) -> foldl_bins(Bins, MP, []). foldl_bins([], Terms) -> - %% Preserve time order (version 9). + %% Preserve time order. Terms; foldl_bins([Bin | Bins], Terms) -> foldl_bins(Bins, [binary_to_term(Bin) | Terms]). foldl_bins([], _MP, Terms) -> - %% Preserve time order (version 9). + %% Preserve time order. Terms; foldl_bins([Bin | Bins], MP, Terms) -> Term = binary_to_term(Bin), @@ -1066,11 +1063,8 @@ foldl_bins([Bin | Bins], MP, Terms) -> compile_match_spec(select, ?PATTERN_TO_OBJECT_MATCH_SPEC('_') = Spec) -> {Spec, true}; compile_match_spec(select, Spec) -> - case catch ets:match_spec_compile(Spec) of - X when is_binary(X) -> - {Spec, X}; - _ -> - badarg + try {Spec, {match_spec, ets:match_spec_compile(Spec)}} + catch error:_ -> badarg end; compile_match_spec(object, Pat) -> compile_match_spec(select, ?PATTERN_TO_OBJECT_MATCH_SPEC(Pat)); @@ -1091,16 +1085,10 @@ defaults(Tab, Args) -> delayed_write = ?DEFAULT_CACHE, auto_save = timer:minutes(?DEFAULT_AUTOSAVE), access = read_write, - version = default, debug = false}, Fun = fun repl/2, Defaults = lists:foldl(Fun, Defaults0, Args), - case Defaults#open_args.version of - 8 -> - Defaults#open_args{max_no_slots = default}; - _ -> - is_comp_min_max(Defaults) - end. + is_comp_min_max(Defaults). to_list(T) when is_atom(T) -> atom_to_list(T); to_list(T) -> T. @@ -1124,12 +1112,13 @@ repl({delayed_write, {Delay,Size} = C}, Defs) Defs#open_args{delayed_write = C}; repl({estimated_no_objects, I}, Defs) -> repl({min_no_slots, I}, Defs); -repl({file, File}, Defs) -> +repl({file, File}, Defs) when is_list(File) -> + Defs#open_args{file = File}; +repl({file, File}, Defs) when is_atom(File) -> Defs#open_args{file = to_list(File)}; repl({keypos, P}, Defs) when is_integer(P), P > 0 -> Defs#open_args{keypos =P}; repl({max_no_slots, I}, Defs) -> - %% Version 9 only. MaxSlots = is_max_no_slots(I), Defs#open_args{max_no_slots = MaxSlots}; repl({min_no_slots, I}, Defs) -> @@ -1145,8 +1134,9 @@ repl({type, T}, Defs) -> mem(T, [set, bag, duplicate_bag]), Defs#open_args{type =T}; repl({version, Version}, Defs) -> - V = is_version(Version), - Defs#open_args{version = V}; + %% Backwards compatibility. + is_version(Version), + Defs; repl({debug, Bool}, Defs) -> %% Not documented. mem(Bool, [true, false]), @@ -1162,16 +1152,15 @@ is_max_no_slots(default) -> default; is_max_no_slots(I) when is_integer(I), I > 0, I < 1 bsl 31 -> I. is_comp_min_max(Defs) -> - #open_args{max_no_slots = Max, min_no_slots = Min, version = V} = Defs, - case V of - _ when Min =:= default -> Defs; - _ when Max =:= default -> Defs; - _ -> true = Min =< Max, Defs + #open_args{max_no_slots = Max, min_no_slots = Min} = Defs, + if + Min =:= default -> Defs; + Max =:= default -> Defs; + true -> true = Min =< Max, Defs end. -is_version(default) -> default; -is_version(8) -> 8; -is_version(9) -> 9. +is_version(default) -> true; +is_version(9) -> true. mem(X, L) -> case lists:member(X, L) of @@ -1286,10 +1275,24 @@ badarg_exit(Reply, _A) -> init(Parent, Server) -> process_flag(trap_exit, true), - open_file_loop(#head{parent = Parent, server = Server}). - -open_file_loop(Head) -> - open_file_loop(Head, 0). + %% The Dets server pretends the file is open before + %% internal_open() has been called, which means that unless the + %% internal_open message is applied first, other processes can + %% find the pid by calling dets_server:get_pid() and do things + %% before Head has been initialized properly. + receive + ?DETS_CALL(From, {internal_open, Ref, Args}=Op) -> + try do_internal_open(Parent, Server, From, Ref, Args) of + Head -> + open_file_loop(Head, 0) + catch + exit:normal -> + exit(normal); + _:Bad -> + bug_found(no_name, Op, Bad, From), + exit(Bad) % give up + end + end. open_file_loop(Head, N) when element(1, Head#head.update_mode) =:= error -> open_file_loop2(Head, N); @@ -1351,7 +1354,7 @@ open_file_loop2(Head, N) -> ?MODULE, [], Head); Message -> error_logger:format("** dets: unexpected message" - "(ignored): ~w~n", [Message]), + "(ignored): ~tw~n", [Message]), open_file_loop(Head, N) end. @@ -1369,28 +1372,7 @@ do_apply_op(Op, From, Head, N) -> exit:normal -> exit(normal); _:Bad -> - Name = Head#head.name, - case dets_utils:debug_mode() of - true -> - %% If stream_op/5 found more requests, this is not - %% the last operation. - error_logger:format - ("** dets: Bug was found when accessing table ~w,~n" - "** dets: operation was ~p and reply was ~w.~n" - "** dets: Stacktrace: ~w~n", - [Name, Op, Bad, erlang:get_stacktrace()]); - false -> - error_logger:format - ("** dets: Bug was found when accessing table ~w~n", - [Name]) - end, - if - From =/= self() -> - From ! {self(), {error, {dets_bug, Name, Op, Bad}}}, - ok; - true -> % auto_save | may_grow | {delayed_write, _} - ok - end, + bug_found(Head#head.name, Op, Bad, From), open_file_loop(Head, N) end. @@ -1398,10 +1380,7 @@ apply_op(Op, From, Head, N) -> case Op of {add_user, Tab, OpenArgs}-> #open_args{file = Fname, type = Type, keypos = Keypos, - ram_file = Ram, access = Access, - version = Version} = OpenArgs, - VersionOK = (Version =:= default) or - (Head#head.version =:= Version), + ram_file = Ram, access = Access} = OpenArgs, %% min_no_slots and max_no_slots are not tested Res = if Tab =:= Head#head.name, @@ -1409,7 +1388,6 @@ apply_op(Op, From, Head, N) -> Head#head.type =:= Type, Head#head.ram_file =:= Ram, Head#head.access =:= Access, - VersionOK, Fname =:= Head#head.filename -> ok; true -> @@ -1425,7 +1403,7 @@ apply_op(Op, From, Head, N) -> Head; _Dirty when N =:= 0 -> % dirty or new_dirty %% The updates seems to have declined - dets_utils:vformat("** dets: Auto save of ~p\n", + dets_utils:vformat("** dets: Auto save of ~tp\n", [Head#head.name]), {NewHead, _Res} = perform_save(Head, true), erlang:garbage_collect(), @@ -1465,21 +1443,14 @@ apply_op(Op, From, Head, N) -> From ! {self(), Res}, ok; {internal_open, Ref, Args} -> - ?PROFILE(ep:do()), - case do_open_file(Args, Head#head.parent, Head#head.server,Ref) of - {ok, H2} -> - From ! {self(), ok}, - H2; - Error -> - From ! {self(), Error}, - exit(normal) - end; + do_internal_open(Head#head.parent, Head#head.server, From, + Ref, Args); may_grow when Head#head.update_mode =/= saved -> if Head#head.update_mode =:= dirty -> %% Won't grow more if the table is full. {H2, _Res} = - (Head#head.mod):may_grow(Head, 0, many_times), + dets_v9:may_grow(Head, 0, many_times), {N + 1, H2}; true -> ok @@ -1509,21 +1480,10 @@ apply_op(Op, From, Head, N) -> From ! {self(), Res}, erlang:garbage_collect(), {0, H2}; - {delete_key, Keys} when Head#head.update_mode =:= dirty -> - if - Head#head.version =:= 8 -> - {H2, Res} = fdelete_key(Head, Keys), - From ! {self(), Res}, - {N + 1, H2}; - true -> - stream_op(Op, From, [], Head, N) - end; + {delete_key, _Keys} when Head#head.update_mode =:= dirty -> + stream_op(Op, From, [], Head, N); {delete_object, Objs} when Head#head.update_mode =:= dirty -> case check_objects(Objs, Head#head.keypos) of - true when Head#head.version =:= 8 -> - {H2, Res} = fdelete_object(Head, Objs), - From ! {self(), Res}, - {N + 1, H2}; true -> stream_op(Op, From, [], Head, N); false -> @@ -1541,10 +1501,6 @@ apply_op(Op, From, Head, N) -> H2; {insert, Objs} when Head#head.update_mode =:= dirty -> case check_objects(Objs, Head#head.keypos) of - true when Head#head.version =:= 8 -> - {H2, Res} = finsert(Head, Objs), - From ! {self(), Res}, - {N + 1, H2}; true -> stream_op(Op, From, [], Head, N); false -> @@ -1555,10 +1511,6 @@ apply_op(Op, From, Head, N) -> {H2, Res} = finsert_new(Head, Objs), From ! {self(), Res}, {N + 1, H2}; - {lookup_keys, Keys} when Head#head.version =:= 8 -> - {H2, Res} = flookup_keys(Head, Keys), - From ! {self(), Res}, - H2; {lookup_keys, _Keys} -> stream_op(Op, From, [], Head, N); {match_init, State, Safe} -> @@ -1574,10 +1526,6 @@ apply_op(Op, From, Head, N) -> {H2, Res} = fmatch(Head, MP, Spec, NObjs, Safe, From), From ! {self(), Res}, H2; - {member, Key} when Head#head.version =:= 8 -> - {H2, Res} = fmember(Head, Key), - From ! {self(), Res}, - H2; {member, _Key} = Op -> stream_op(Op, From, [], Head, N); {next, Key} -> @@ -1618,7 +1566,7 @@ apply_op(Op, From, Head, N) -> apply_op(WriteOp, From, H2, 0); WriteOp when Head#head.access =:= read_write, Head#head.update_mode =:= saved -> - case catch (Head#head.mod):mark_dirty(Head) of + case catch dets_v9:mark_dirty(Head) of ok -> start_auto_save_timer(Head), H2 = Head#head{update_mode = dirty}, @@ -1633,6 +1581,40 @@ apply_op(Op, From, Head, N) -> ok end. +bug_found(Name, Op, Bad, From) -> + case dets_utils:debug_mode() of + true -> + %% If stream_op/5 found more requests, this is not + %% the last operation. + error_logger:format + ("** dets: Bug was found when accessing table ~tw,~n" + "** dets: operation was ~tp and reply was ~tw.~n" + "** dets: Stacktrace: ~tw~n", + [Name, Op, Bad, erlang:get_stacktrace()]); + false -> + error_logger:format + ("** dets: Bug was found when accessing table ~tw~n", + [Name]) + end, + if + From =/= self() -> + From ! {self(), {error, {dets_bug, Name, Op, Bad}}}, + ok; + true -> % auto_save | may_grow | {delayed_write, _} + ok + end. + +do_internal_open(Parent, Server, From, Ref, Args) -> + ?PROFILE(ep:do()), + case do_open_file(Args, Parent, Server, Ref) of + {ok, Head} -> + From ! {self(), ok}, + Head; + Error -> + From ! {self(), Error}, + exit(normal) + end. + start_auto_save_timer(Head) when Head#head.auto_save =:= infinity -> ok; start_auto_save_timer(Head) -> @@ -1640,7 +1622,7 @@ start_auto_save_timer(Head) -> _Ref = erlang:send_after(Millis, self(), ?DETS_CALL(self(), auto_save)), ok. -%% Version 9: Peek the message queue and try to evaluate several +%% Peek the message queue and try to evaluate several %% lookup requests in parallel. Evalute delete_object, delete and %% insert as well. stream_op(Op, Pid, Pids, Head, N) -> @@ -1750,7 +1732,7 @@ lookup_reply(P, O) -> %% Callback functions for system messages handling. %%----------------------------------------------------------------- system_continue(_Parent, _, Head) -> - open_file_loop(Head). + open_file_loop(Head, 0). system_terminate(Reason, _Parent, _, Head) -> _NewHead = do_stop(Head), @@ -1783,7 +1765,8 @@ read_file_header(FileName, Access, RamFile) -> dets_utils:pread_close(Fd, FileName, ?FILE_FORMAT_VERSION_POS, 4), if Version =< 8 -> - dets_v8:read_file_header(Fd, FileName); + _ = file:close(Fd), + throw({error, {format_8_no_longer_supported, FileName}}); Version =:= 9 -> dets_v9:read_file_header(Fd, FileName); true -> @@ -1810,7 +1793,7 @@ perform_save(Head, DoSync) when Head#head.update_mode =:= dirty; Head#head.update_mode =:= new_dirty -> case catch begin {Head1, []} = write_cache(Head), - {Head2, ok} = (Head1#head.mod):do_perform_save(Head1), + {Head2, ok} = dets_v9:do_perform_save(Head1), ok = ensure_written(Head2, DoSync), {Head2#head{update_mode = saved}, ok} end of @@ -1843,7 +1826,7 @@ ensure_written(Head, false) when not Head#head.ram_file -> do_bchunk_init(Head, Tab) -> case catch write_cache(Head) of {H2, []} -> - case (H2#head.mod):table_parameters(H2) of + case dets_v9:table_parameters(H2) of undefined -> {H2, {error, old_version}}; Parms -> @@ -1852,9 +1835,9 @@ do_bchunk_init(Head, Tab) -> L =:= <<>> -> eof; true -> <<>> end, - C0 = #dets_cont{no_objs = default, bin = Bin, alloc = L}, BinParms = term_to_binary(Parms), - {H2, {C0#dets_cont{tab = Tab, proc = self(),what = bchunk}, + {H2, {#dets_cont{no_objs = default, bin = Bin, alloc = L, + tab = Tab, proc = self(),what = bchunk}, [BinParms]}} end; {NewHead, _} = HeadError when is_record(NewHead, head) -> @@ -1894,16 +1877,8 @@ do_delete_all_objects(Head) -> max_no_slots = MaxSlots, cache = Cache} = Head, CacheSz = dets_utils:cache_size(Cache), ok = dets_utils:truncate(Fd, Fname, bof), - (Head#head.mod):initiate_file(Fd, Tab, Fname, Type, Kp, MinSlots, MaxSlots, - Ram, CacheSz, Auto, true). - -%% -> {NewHead, Reply}, Reply = ok | Error. -fdelete_key(Head, Keys) -> - do_delete(Head, Keys, delete_key). - -%% -> {NewHead, Reply}, Reply = ok | badarg | Error. -fdelete_object(Head, Objects) -> - do_delete(Head, Objects, delete_object). + dets_v9:initiate_file(Fd, Tab, Fname, Type, Kp, MinSlots, MaxSlots, + Ram, CacheSz, Auto, true). ffirst(H) -> Ref = make_ref(), @@ -1920,7 +1895,7 @@ ffirst1(H) -> ffirst(NH, 0). ffirst(H, Slot) -> - case (H#head.mod):slot_objs(H, Slot) of + case dets_v9:slot_objs(H, Slot) of '$end_of_table' -> {H, '$end_of_table'}; [] -> ffirst(H, Slot+1); [X|_] -> {H, element(H#head.keypos, X)} @@ -1964,7 +1939,9 @@ do_safe_fixtable(Head, Pid, true) -> case Head#head.fixed of false -> link(Pid), - Fixed = {utime_now(), [{Pid, 1}]}, + MonTime = erlang:monotonic_time(), + TimeOffset = erlang:time_offset(), + Fixed = {{MonTime, TimeOffset}, [{Pid, 1}]}, Ftab = dets_utils:get_freelists(Head), Head#head{fixed = Fixed, freelists = {Ftab, Ftab}}; {TimeStamp, Counters} -> @@ -2055,7 +2032,7 @@ finfo(H, auto_save) -> {H, H#head.auto_save}; finfo(H, bchunk_format) -> case catch write_cache(H) of {H2, []} -> - case (H2#head.mod):table_parameters(H2) of + case dets_v9:table_parameters(H2) of undefined = Undef -> {H2, Undef}; Parms -> @@ -2088,10 +2065,25 @@ finfo(H, no_keys) -> {H2, _} = HeadError when is_record(H2, head) -> HeadError end; -finfo(H, no_slots) -> {H, (H#head.mod):no_slots(H)}; +finfo(H, no_slots) -> {H, dets_v9:no_slots(H)}; finfo(H, pid) -> {H, self()}; finfo(H, ram_file) -> {H, H#head.ram_file}; -finfo(H, safe_fixed) -> {H, H#head.fixed}; +finfo(H, safe_fixed) -> + {H, + case H#head.fixed of + false -> + false; + {{FixMonTime, TimeOffset}, RefList} -> + {make_timestamp(FixMonTime, TimeOffset), RefList} + end}; +finfo(H, safe_fixed_monotonic_time) -> + {H, + case H#head.fixed of + false -> + false; + {{FixMonTime, _TimeOffset}, RefList} -> + {FixMonTime, RefList} + end}; finfo(H, size) -> case catch write_cache(H) of {H2, []} -> @@ -2100,7 +2092,7 @@ finfo(H, size) -> HeadError end; finfo(H, type) -> {H, H#head.type}; -finfo(H, version) -> {H, H#head.version}; +finfo(H, version) -> {H, 9}; finfo(H, _) -> {H, undefined}. file_size(Fd, FileName) -> @@ -2109,8 +2101,6 @@ file_size(Fd, FileName) -> test_bchunk_format(_Head, undefined) -> false; -test_bchunk_format(Head, _Term) when Head#head.version =:= 8 -> - false; test_bchunk_format(Head, Term) -> dets_v9:try_bchunk_header(Term, Head) =/= not_ok. @@ -2127,7 +2117,7 @@ do_open_file([Fname, Verbose], Parent, Server, Ref) -> Error; Bad -> error_logger:format - ("** dets: Bug was found in open_file/1, reply was ~w.~n", + ("** dets: Bug was found in open_file/1, reply was ~tw.~n", [Bad]), {error, {dets_bug, Fname, Bad}} end; @@ -2145,7 +2135,7 @@ do_open_file([Tab, OpenArgs, Verb], Parent, Server, _Ref) -> Bad -> error_logger:format ("** dets: Bug was found in open_file/2, arguments were~n" - "** dets: ~w and reply was ~w.~n", + "** dets: ~tw and reply was ~tw.~n", [OpenArgs, Bad]), {error, {dets_bug, Tab, {open_file, OpenArgs}, Bad}} end. @@ -2179,7 +2169,7 @@ do_finit(Head, Init, Format, NoSlots) -> #head{fptr = Fd, type = Type, keypos = Kp, auto_save = Auto, cache = Cache, filename = Fname, ram_file = Ram, min_no_slots = MinSlots0, max_no_slots = MaxSlots, - name = Tab, update_mode = UpdateMode, mod = HMod} = Head, + name = Tab, update_mode = UpdateMode} = Head, CacheSz = dets_utils:cache_size(Cache), {How, Head1} = case Format of @@ -2192,9 +2182,10 @@ do_finit(Head, Init, Format, NoSlots) -> {general_init, Head}; true -> ok = dets_utils:truncate(Fd, Fname, bof), - {ok, H} = HMod:initiate_file(Fd, Tab, Fname, Type, Kp, - MinSlots, MaxSlots, Ram, - CacheSz, Auto, false), + {ok, H} = + dets_v9:initiate_file(Fd, Tab, Fname, Type, Kp, + MinSlots, MaxSlots, Ram, + CacheSz, Auto, false), {general_init, H} end; bchunk -> @@ -2203,7 +2194,7 @@ do_finit(Head, Init, Format, NoSlots) -> end, case How of bchunk_init -> - case HMod:bchunk_init(Head1, Init) of + case dets_v9:bchunk_init(Head1, Init) of {ok, NewHead} -> {ok, NewHead#head{update_mode = dirty}}; Error -> @@ -2211,10 +2202,10 @@ do_finit(Head, Init, Format, NoSlots) -> end; general_init -> Cntrs = ets:new(dets_init, []), - Input = HMod:bulk_input(Head1, Init, Cntrs), + Input = dets_v9:bulk_input(Head1, Init, Cntrs), SlotNumbers = {Head1#head.min_no_slots, bulk_init, MaxSlots}, {Reply, SizeData} = - do_sort(Head1, SlotNumbers, Input, Cntrs, Fname, not_used), + do_sort(Head1, SlotNumbers, Input, Cntrs, Fname), Bulk = true, case Reply of {ok, NoDups, H1} -> @@ -2270,7 +2261,8 @@ fmatch(Head, MP, Spec, N, Safe, From) -> {NewHead, Reply} = flookup_keys(Head, Keys), case Reply of Objs when is_list(Objs) -> - MatchingObjs = ets:match_spec_run(Objs, MP), + {match_spec, MS} = MP, + MatchingObjs = ets:match_spec_run(Objs, MS), {NewHead, {done, MatchingObjs}}; Error -> {NewHead, Error} @@ -2350,7 +2342,7 @@ fmatch_delete(Head, C) -> {[], _} -> {Head, {done, 0}}; {RTs, NC} -> - MP = C#dets_cont.match_program, + {match_spec, MP} = C#dets_cont.match_program, case catch filter_binary_terms(RTs, MP, []) of {'EXIT', _} -> Bad = dets_utils:bad_object(fmatch_delete, RTs), @@ -2378,7 +2370,7 @@ do_fmatch_delete_var_keys(Head, MP, _Spec, From) -> C0 = init_scan(NewHead, default), {NewHead, {cont, C0#dets_cont{match_program = MP}, 0}}. -do_fmatch_constant_keys(Head, Keys, MP) -> +do_fmatch_constant_keys(Head, Keys, {match_spec, MP}) -> case flookup_keys(Head, Keys) of {NewHead, ReadTerms} when is_list(ReadTerms) -> Terms = filter_terms(ReadTerms, MP, []), @@ -2427,18 +2419,8 @@ do_delete(Head, Things, What) -> HeadError end. -fmember(Head, Key) -> - case catch begin - {Head2, [{_NoPid,Objs}]} = - update_cache(Head, [Key], {lookup, nopid}), - {Head2, Objs =/= []} - end of - {NewHead, _} = Reply when is_record(NewHead, head) -> - Reply - end. - fnext(Head, Key) -> - Slot = (Head#head.mod):db_hash(Key, Head), + Slot = dets_v9:db_hash(Key, Head), Ref = make_ref(), case catch {Ref, fnext(Head, Key, Slot)} of {Ref, {H, R}} -> @@ -2449,7 +2431,7 @@ fnext(Head, Key) -> fnext(H, Key, Slot) -> {NH, []} = write_cache(H), - case (H#head.mod):slot_objs(NH, Slot) of + case dets_v9:slot_objs(NH, Slot) of '$end_of_table' -> {NH, '$end_of_table'}; L -> fnext_search(NH, Key, Slot, L) end. @@ -2463,7 +2445,7 @@ fnext_search(H, K, Slot, L) -> %% We've got to continue to search for the next key in the next slot fnext_slot(H, K, Slot) -> - case (H#head.mod):slot_objs(H, Slot) of + case dets_v9:slot_objs(H, Slot) of '$end_of_table' -> {H, '$end_of_table'}; [] -> fnext_slot(H, K, Slot+1); L -> {H, element(H#head.keypos, hd(L))} @@ -2491,11 +2473,10 @@ fopen2(Fname, Tab) -> Acc = read_write, Ram = false, {ok, Fd, FH} = read_file_header(Fname, Acc, Ram), - Mod = FH#fileheader.mod, - Do = case Mod:check_file_header(FH, Fd) of - {ok, Head1, ExtraInfo} -> + Do = case dets_v9:check_file_header(FH, Fd) of + {ok, Head1} -> Head2 = Head1#head{filename = Fname}, - try {ok, Mod:init_freelist(Head2, ExtraInfo)} + try {ok, dets_v9:init_freelist(Head2)} catch throw:_ -> {repair, " has bad free lists, repairing ..."} @@ -2509,8 +2490,7 @@ fopen2(Fname, Tab) -> case Do of {repair, Mess} -> io:format(user, "dets: file ~tp~s~n", [Fname, Mess]), - Version = default, - case fsck(Fd, Tab, Fname, FH, default, default, Version) of + case fsck(Fd, Tab, Fname, FH, default, default) of ok -> fopen2(Fname, Tab); Error -> @@ -2543,33 +2523,23 @@ fopen_existing_file(Tab, OpenArgs) -> #open_args{file = Fname, type = Type, keypos = Kp, repair = Rep, min_no_slots = MinSlots, max_no_slots = MaxSlots, ram_file = Ram, delayed_write = CacheSz, auto_save = - Auto, access = Acc, version = Version, debug = Debug} = + Auto, access = Acc, debug = Debug} = OpenArgs, {ok, Fd, FH} = read_file_header(Fname, Acc, Ram), - V9 = (Version =:= 9) or (Version =:= default), MinF = (MinSlots =:= default) or (MinSlots =:= FH#fileheader.min_no_slots), MaxF = (MaxSlots =:= default) or (MaxSlots =:= FH#fileheader.max_no_slots), - Mod = (FH#fileheader.mod), - Wh = case Mod:check_file_header(FH, Fd) of - {ok, Head, true} when Rep =:= force, Acc =:= read_write, - FH#fileheader.version =:= 9, - FH#fileheader.no_colls =/= undefined, - MinF, MaxF, V9 -> - {compact, Head, true}; - {ok, _Head, _Extra} when Rep =:= force, Acc =:= read -> + Wh = case dets_v9:check_file_header(FH, Fd) of + {ok, Head} when Rep =:= force, Acc =:= read_write, + FH#fileheader.no_colls =/= undefined, + MinF, MaxF -> + {compact, Head}; + {ok, _Head} when Rep =:= force, Acc =:= read -> throw({error, {access_mode, Fname}}); - {ok, Head, need_compacting} when Acc =:= read -> - {final, Head, true}; % Version 8 only. - {ok, _Head, need_compacting} when Rep =:= true -> - %% The file needs to be compacted due to a very big - %% and fragmented free_list. Version 8 only. - M = " is now compacted ...", - {repair, M}; - {ok, _Head, _Extra} when Rep =:= force -> + {ok, _Head} when Rep =:= force -> M = ", repair forced.", {repair, M}; - {ok, Head, ExtraInfo} -> - {final, Head, ExtraInfo}; + {ok, Head} -> + {final, Head}; {error, not_closed} when Rep =:= force, Acc =:= read_write -> M = ", repair forced.", {repair, M}; @@ -2578,17 +2548,13 @@ fopen_existing_file(Tab, OpenArgs) -> {repair, M}; {error, not_closed} when Rep =:= false -> throw({error, {needs_repair, Fname}}); - {error, version_bump} when Rep =:= true, Acc =:= read_write -> - %% Version 8 only - M = " old version, upgrading ...", - {repair, M}; {error, Reason} -> throw({error, {Reason, Fname}}) end, Do = case Wh of - {Tag, Hd, Extra} when Tag =:= final; Tag =:= compact -> + {Tag, Hd} when Tag =:= final; Tag =:= compact -> Hd1 = Hd#head{filename = Fname}, - try {Tag, Mod:init_freelist(Hd1, Extra)} + try {Tag, dets_v9:init_freelist(Hd1)} catch throw:_ -> {repair, " has bad free lists, repairing ..."} @@ -2616,23 +2582,20 @@ fopen_existing_file(Tab, OpenArgs) -> "now repairing ...~n", [Fname]), {ok, Fd2, _FH} = read_file_header(Fname, Acc, Ram), do_repair(Fd2, Tab, Fname, FH, MinSlots, MaxSlots, - Version, OpenArgs) + OpenArgs) end; {repair, Mess} -> io:format(user, "dets: file ~tp~s~n", [Fname, Mess]), do_repair(Fd, Tab, Fname, FH, MinSlots, MaxSlots, - Version, OpenArgs); - _ when FH#fileheader.version =/= Version, Version =/= default -> - throw({error, {version_mismatch, Fname}}); + OpenArgs); {final, H} -> H1 = H#head{auto_save = Auto}, open_final(H1, Fname, Acc, Ram, CacheSz, Tab, Debug) end. -do_repair(Fd, Tab, Fname, FH, MinSlots, MaxSlots, Version, OpenArgs) -> - case fsck(Fd, Tab, Fname, FH, MinSlots, MaxSlots, Version) of +do_repair(Fd, Tab, Fname, FH, MinSlots, MaxSlots, OpenArgs) -> + case fsck(Fd, Tab, Fname, FH, MinSlots, MaxSlots) of ok -> - %% No need to update 'version'. erlang:garbage_collect(), fopen3(Tab, OpenArgs#open_args{repair = false}); Error -> @@ -2646,8 +2609,8 @@ open_final(Head, Fname, Acc, Ram, CacheSz, Tab, Debug) -> filename = Fname, name = Tab, cache = dets_utils:new_cache(CacheSz)}, - init_disk_map(Head1#head.version, Tab, Debug), - (Head1#head.mod):cache_segps(Head1#head.fptr, Fname, Head1#head.next), + init_disk_map(Tab, Debug), + dets_v9:cache_segps(Head1#head.fptr, Fname, Head1#head.next), check_growth(Head1), {ok, Head1}. @@ -2656,7 +2619,7 @@ fopen_init_file(Tab, OpenArgs) -> #open_args{file = Fname, type = Type, keypos = Kp, min_no_slots = MinSlotsArg, max_no_slots = MaxSlotsArg, ram_file = Ram, delayed_write = CacheSz, auto_save = Auto, - version = UseVersion, debug = Debug} = OpenArgs, + debug = Debug} = OpenArgs, MinSlots = choose_no_slots(MinSlotsArg, ?DEFAULT_MIN_NO_SLOTS), MaxSlots = choose_no_slots(MaxSlotsArg, ?DEFAULT_MAX_NO_SLOTS), FileSpec = if @@ -2664,20 +2627,11 @@ fopen_init_file(Tab, OpenArgs) -> true -> Fname end, {ok, Fd} = dets_utils:open(FileSpec, open_args(read_write, Ram)), - Version = if - UseVersion =:= default -> - case os:getenv("DETS_USE_FILE_FORMAT") of - "8" -> 8; - _ -> 9 - end; - true -> - UseVersion - end, - Mod = version2module(Version), %% No need to truncate an empty file. - init_disk_map(Version, Tab, Debug), - case catch Mod:initiate_file(Fd, Tab, Fname, Type, Kp, MinSlots, MaxSlots, - Ram, CacheSz, Auto, true) of + init_disk_map(Tab, Debug), + case catch dets_v9:initiate_file(Fd, Tab, Fname, Type, Kp, + MinSlots, MaxSlots, + Ram, CacheSz, Auto, true) of {error, Reason} when Ram -> _ = file:close(Fd), throw({error, Reason}); @@ -2692,15 +2646,13 @@ fopen_init_file(Tab, OpenArgs) -> end. %% Debug. -init_disk_map(9, Name, Debug) -> +init_disk_map(Name, Debug) -> case Debug orelse dets_utils:debug_mode() of true -> dets_utils:init_disk_map(Name); false -> ok - end; -init_disk_map(_Version, _Name, _Debug) -> - ok. + end. open_args(Access, RamFile) -> A1 = case Access of @@ -2713,15 +2665,7 @@ open_args(Access, RamFile) -> end, A1 ++ A2 ++ [binary, read]. -version2module(V) when V =< 8 -> dets_v8; -version2module(9) -> dets_v9. - -module2version(dets_v8) -> 8; -module2version(dets_v9) -> 9; -module2version(not_used) -> 9. - %% -> ok | throw(Error) -%% For version 9 tables only. compact(SourceHead) -> #head{name = Tab, filename = Fname, fptr = SFd, type = Type, keypos = Kp, ram_file = Ram, auto_save = Auto} = SourceHead, @@ -2732,7 +2676,7 @@ compact(SourceHead) -> %% It is normally not possible to have two open tables in the same %% process since the process dictionary is used for caching %% segment pointers, but here is works anyway--when reading a file - %% serially the pointers to not need to be used. + %% serially the pointers do not need to be used. Head = case catch dets_v9:prep_table_copy(Fd, Tab, Tmp, Type, Kp, Ram, CacheSz, Auto, TblParms) of {ok, H} -> @@ -2767,7 +2711,7 @@ compact(SourceHead) -> %% -> ok | Error %% Closes Fd. -fsck(Fd, Tab, Fname, FH, MinSlotsArg, MaxSlotsArg, Version) -> +fsck(Fd, Tab, Fname, FH, MinSlotsArg, MaxSlotsArg) -> %% MinSlots and MaxSlots are the option values. #fileheader{min_no_slots = MinSlotsFile, max_no_slots = MaxSlotsFile} = FH, @@ -2780,10 +2724,10 @@ fsck(Fd, Tab, Fname, FH, MinSlotsArg, MaxSlotsArg, Version) -> %% If the number of objects (keys) turns out to be significantly %% different from NoSlots, we try again with the correct number of %% objects (keys). - case fsck_try(Fd, Tab, FH, Fname, SlotNumbers, Version) of + case fsck_try(Fd, Tab, FH, Fname, SlotNumbers) of {try_again, BetterNoSlots} -> BetterSlotNumbers = {MinSlots, BetterNoSlots, MaxSlots}, - case fsck_try(Fd, Tab, FH, Fname, BetterSlotNumbers, Version) of + case fsck_try(Fd, Tab, FH, Fname, BetterSlotNumbers) of {try_again, _} -> _ = file:close(Fd), {error, {cannot_repair, Fname}}; @@ -2802,7 +2746,7 @@ choose_no_slots(NoSlots, _) -> NoSlots. %% Initiating a table using a fun and repairing (or converting) a %% file are completely different things, but nevertheless the same %% method is used in both cases... -fsck_try(Fd, Tab, FH, Fname, SlotNumbers, Version) -> +fsck_try(Fd, Tab, FH, Fname, SlotNumbers) -> Tmp = tempfile(Fname), #fileheader{type = Type, keypos = KeyPos} = FH, {_MinSlots, EstNoSlots, MaxSlots} = SlotNumbers, @@ -2811,7 +2755,7 @@ fsck_try(Fd, Tab, FH, Fname, SlotNumbers, Version) -> max_no_slots = MaxSlots, ram_file = false, delayed_write = ?DEFAULT_CACHE, auto_save = infinity, access = read_write, - version = Version, debug = false}, + debug = false}, case catch fopen3(Tab, OpenArgs) of {ok, Head} -> case fsck_try_est(Head, Fd, Fname, SlotNumbers, FH) of @@ -2861,10 +2805,9 @@ assure_no_file(File) -> %% -> {ok, NewHead} | {try_again, integer()} | Error fsck_try_est(Head, Fd, Fname, SlotNumbers, FH) -> %% Mod is the module to use for reading input when repairing. - Mod = FH#fileheader.mod, Cntrs = ets:new(dets_repair, []), - Input = Mod:fsck_input(Head, Fd, Cntrs, FH), - {Reply, SizeData} = do_sort(Head, SlotNumbers, Input, Cntrs, Fname, Mod), + Input = dets_v9:fsck_input(Head, Fd, Cntrs, FH), + {Reply, SizeData} = do_sort(Head, SlotNumbers, Input, Cntrs, Fname), Bulk = false, case Reply of {ok, NoDups, H1} -> @@ -2879,14 +2822,13 @@ fsck_try_est(Head, Fd, Fname, SlotNumbers, FH) -> Else end. -do_sort(Head, SlotNumbers, Input, Cntrs, Fname, Mod) -> - OldV = module2version(Mod), +do_sort(Head, SlotNumbers, Input, Cntrs, Fname) -> %% output_objs/4 replaces {LogSize,NoObjects} in Cntrs by %% {LogSize,Position,Data,NoObjects | NoCollections}. %% Data = {FileName,FileDescriptor} | [object()] - %% For small tables Data may be a list of objects which is more + %% For small tables Data can be a list of objects which is more %% efficient since no temporary files are created. - Output = (Head#head.mod):output_objs(OldV, Head, SlotNumbers, Cntrs), + Output = dets_v9:output_objs(Head, SlotNumbers, Cntrs), TmpDir = filename:dirname(Fname), Reply = (catch file_sorter:sort(Input, Output, [{format, binary},{tmpdir, TmpDir}])), @@ -2927,13 +2869,6 @@ fsck_copy1([SzData | L], Head, Bulk, NoDups) -> {ok, Copied} when Copied =:= ExpectedSize; NoObjects =:= 0 -> % the segments fsck_copy1(L, Head, Bulk, NoDups); - {ok, Copied} when Bulk, Head#head.version =:= 8 -> - NoZeros = ExpectedSize - Copied, - Dups = NoZeros div Size, - Addr = Pos+Copied, - NewHead = free_n_objects(Head, Addr, Size-1, NoDups), - NewNoDups = NoDups - Dups, - fsck_copy1(L, NewHead, Bulk, NewNoDups); {ok, _Copied} -> % should never happen close_files(Bulk, L, Head), Reason = if Bulk -> initialization_failed; @@ -2948,13 +2883,6 @@ fsck_copy1([], Head, _Bulk, NoDups) when NoDups =/= 0 -> fsck_copy1([], Head, _Bulk, _NoDups) -> {ok, Head#head{update_mode = dirty}}. -free_n_objects(Head, _Addr, _Size, 0) -> - Head; -free_n_objects(Head, Addr, Size, N) -> - {NewHead, _} = dets_utils:free(Head, Addr, Size), - NewAddr = Addr + Size + 1, - free_n_objects(NewHead, NewAddr, Size, N-1). - close_files(false, SizeData, Head) -> _ = file:close(Head#head.fptr), close_files(true, SizeData, Head); @@ -2973,7 +2901,7 @@ close_tmp(Fd) -> fslot(H, Slot) -> case catch begin {NH, []} = write_cache(H), - Objs = (NH#head.mod):slot_objs(NH, Slot), + Objs = dets_v9:slot_objs(NH, Slot), {NH, Objs} end of {NewHead, _Objects} = Reply when is_record(NewHead, head) -> @@ -3023,7 +2951,7 @@ where_is_object(Head, Object) -> true -> case catch write_cache(Head) of {NewHead, []} -> - {NewHead, (Head#head.mod):find_object(NewHead, Object)}; + {NewHead, dets_v9:find_object(NewHead, Object)}; {NewHead, _} = HeadError when is_record(NewHead, head) -> HeadError end; @@ -3036,13 +2964,9 @@ check_objects([T | Ts], Kp) when tuple_size(T) >= Kp -> check_objects(L, _Kp) -> L =:= []. -no_things(Head) when Head#head.no_keys =:= undefined -> - Head#head.no_objects; no_things(Head) -> Head#head.no_keys. -file_no_things(FH) when FH#fileheader.no_keys =:= undefined -> - FH#fileheader.no_objects; file_no_things(FH) -> FH#fileheader.no_keys. @@ -3083,7 +3007,7 @@ update_cache(Head, ToAdd) -> if Lookup; NewSize >= Cache#cache.tsize -> %% The cache is considered full, or some lookup. - {NewHead, LU, PwriteList} = (Head#head.mod):write_cache(Head1), + {NewHead, LU, PwriteList} = dets_v9:write_cache(Head1), {NewHead, Found ++ LU, PwriteList}; NewC =:= [] -> {Head1, Found, []}; @@ -3168,7 +3092,7 @@ delayed_write(Head, WrTime) -> %% -> {NewHead, [LookedUpObject]} | throw({NewHead, Error}) write_cache(Head) -> - {Head1, LU, PwriteList} = (Head#head.mod):write_cache(Head), + {Head1, LU, PwriteList} = dets_v9:write_cache(Head), {NewHead, ok} = dets_utils:pwrite(Head1, PwriteList), {NewHead, LU}. @@ -3199,7 +3123,7 @@ check_safe_fixtable(Head) -> ((get(verbose) =:= yes) orelse dets_utils:debug_mode()) of true -> error_logger:format - ("** dets: traversal of ~p needs safe_fixtable~n", + ("** dets: traversal of ~tp needs safe_fixtable~n", [Head#head.name]); false -> ok @@ -3221,7 +3145,7 @@ scan(Head, C) -> % when is_record(C, dets_cont) scan(Bin, Head, From, To, L, [], R, {C, Head#head.type}). scan(Bin, H, From, To, L, Ts, R, {C0, Type} = C) -> - case (H#head.mod):scan_objs(H, Bin, From, To, L, Ts, R, Type) of + case dets_v9:scan_objs(H, Bin, From, To, L, Ts, R, Type) of {more, NFrom, NTo, NL, NTs, NR, Sz} -> scan_read(H, NFrom, NTo, Sz, NL, NTs, NR, C); {stop, <<>>=B, NFrom, NTo, <<>>=NL, NTs} -> @@ -3265,7 +3189,7 @@ scan_read(H, From, _To, Min, _L, Ts, R, C) -> err(Error) -> case get(verbose) of yes -> - error_logger:format("** dets: failed with ~w~n", [Error]), + error_logger:format("** dets: failed with ~tw~n", [Error]), Error; undefined -> Error @@ -3275,11 +3199,14 @@ err(Error) -> time_now() -> erlang:monotonic_time(1000000). --compile({inline, [utime_now/0]}). -utime_now() -> - Time = time_now(), - UniqueCounter = erlang:unique_integer([monotonic]), - {Time, UniqueCounter}. +make_timestamp(MonTime, TimeOffset) -> + ErlangSystemTime = erlang:convert_time_unit(MonTime+TimeOffset, + native, + microsecond), + MegaSecs = ErlangSystemTime div 1000000000000, + Secs = ErlangSystemTime div 1000000 - MegaSecs*1000000, + MicroSecs = ErlangSystemTime rem 1000000, + {MegaSecs, Secs, MicroSecs}. %%%%%%%%%%%%%%%%% DEBUG functions %%%%%%%%%%%%%%%% @@ -3287,7 +3214,7 @@ file_info(FileName) -> case catch read_file_header(FileName, read, false) of {ok, Fd, FH} -> _ = file:close(Fd), - (FH#fileheader.mod):file_info(FH); + dets_v9:file_info(FH); Other -> Other end. @@ -3302,15 +3229,13 @@ get_head_field(Fd, Field) -> view(FileName) -> case catch read_file_header(FileName, read, false) of {ok, Fd, FH} -> - Mod = FH#fileheader.mod, - try Mod:check_file_header(FH, Fd) of - {ok, H0, ExtraInfo} -> - Mod = FH#fileheader.mod, - case Mod:check_file_header(FH, Fd) of - {ok, H0, ExtraInfo} -> - H = Mod:init_freelist(H0, ExtraInfo), + try dets_v9:check_file_header(FH, Fd) of + {ok, H0} -> + case dets_v9:check_file_header(FH, Fd) of + {ok, H0} -> + H = dets_v9:init_freelist(H0), v_free_list(H), - Mod:v_segments(H), + dets_v9:v_segments(H), ok; X -> X diff --git a/lib/stdlib/src/dets.hrl b/lib/stdlib/src/dets.hrl index be51e1a89c..b5e732b08f 100644 --- a/lib/stdlib/src/dets.hrl +++ b/lib/stdlib/src/dets.hrl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2001-2011. All Rights Reserved. +%% Copyright Ericsson AB 2001-2016. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -21,7 +21,7 @@ -define(DEFAULT_MIN_NO_SLOTS, 256). -define(DEFAULT_MAX_NO_SLOTS, 32*1024*1024). -define(DEFAULT_AUTOSAVE, 3). % minutes --define(DEFAULT_CACHE, {3000, 14000}). % {delay,size} in {milliseconds,bytes} +-define(DEFAULT_CACHE, {3000, 14000}). % cache_parms() %% Type. -define(SET, 1). @@ -46,83 +46,111 @@ -define(DETS_CALL(Pid, Req), {'$dets_call', Pid, Req}). +-type access() :: 'read' | 'read_write'. +-type auto_save() :: 'infinity' | non_neg_integer(). +-type hash_bif() :: 'phash' | 'phash2'. +-type keypos() :: pos_integer(). +-type no_colls() :: [{LogSize :: non_neg_integer(), + NoCollections :: non_neg_integer()}]. +-type no_slots() :: 'default' | non_neg_integer(). +-type tab_name() :: term(). +-type type() :: 'bag' | 'duplicate_bag' | 'set'. +-type update_mode() :: 'dirty' + | 'new_dirty' + | 'saved' + | {'error', Reason :: term()}. + %% Record holding the file header and more. -record(head, { - m, % size - m2, % m * 2 - next, % next position for growth (segm mgmt only) - fptr, % the file descriptor - no_objects, % number of objects in table, - no_keys, % number of keys (version 9 only) - maxobjsize, % 2-log of the size of the biggest object - % collection (version 9 only) + m :: non_neg_integer(), % size + m2 :: non_neg_integer(), % m * 2 + next :: non_neg_integer(), % next position for growth + % (segm mgmt only) + fptr :: file:fd(), % the file descriptor + no_objects :: non_neg_integer() , % number of objects in table, + no_keys :: non_neg_integer(), % number of keys + maxobjsize :: 'undefined' | non_neg_integer(), % 2-log of + % the size of the biggest object collection n, % split indicator - type, % set | bag | duplicate_bag - keypos, % default is 1 as for ets - freelists, % tuple of free lists of buddies - % if fixed =/= false, then a pair of freelists - freelists_p, % cached FreelistsPointer - no_collections, % [{LogSize,NoCollections}] | undefined; number of - % object collections per size (version 9(b)) - auto_save, % Integer | infinity - update_mode, % saved | dirty | new_dirty | {error, Reason} - fixed = false, % false | {now_time(), [{pid(),Counter}]} - % time of first fix, and number of fixes per process - hash_bif, % hash bif used for this file (phash2, phash, hash) - has_md5, % whether the header has an MD5 sum (version 9(c)) - min_no_slots, % minimum number of slots (default or integer) - max_no_slots, % maximum number of slots (default or integer) - cache, % cache(). Write cache. - - filename, % name of the file being used - access = read_write, % read | read_write - ram_file = false, % true | false - name, % the name of the table - - parent, % The supervisor of Dets processes. - server, % The creator of Dets processes. - - %% Depending on the file format: - version, - mod, - bump, - base + type :: type(), + keypos :: keypos(), % default is 1 as for ets + freelists :: 'undefined' + | tuple(), % tuple of free lists of buddies + % if fixed =/= false, then a pair of freelists + freelists_p :: 'undefined' + | non_neg_integer(), % cached FreelistsPointer + no_collections :: 'undefined' + | no_colls(), % number of object collections + % per size (version 9(b)) + auto_save :: auto_save(), + update_mode :: update_mode(), + fixed = false :: 'false' + | {{integer(), integer()}, % time of first fix, + [{pid(), % and number of fixes per process + non_neg_integer()}]}, + hash_bif :: hash_bif(), % hash bif used for this file + has_md5 :: boolean(), % whether the header has + % an MD5 sum (version 9(c)) + min_no_slots :: no_slots(), % minimum number of slots + max_no_slots :: no_slots(), % maximum number of slots + cache :: 'undefined' | cache(), % Write cache. + + filename :: file:name(), % name of the file being used + access = read_write :: access(), + ram_file = false :: boolean(), + name :: tab_name(), % the name of the table + + parent :: 'undefined' | pid(), % The supervisor of Dets processes. + server :: 'undefined' | pid(), % The creator of Dets processes. + + bump :: non_neg_integer(), + base :: non_neg_integer() }). %% Info extracted from the file header. -record(fileheader, { - freelist, - fl_base, - cookie, - closed_properly, - type, - version, - m, - next, - keypos, - no_objects, - no_keys, - min_no_slots, - max_no_slots, - no_colls, - hash_method, - read_md5, - has_md5, - md5, - trailer, - eof, - n, - mod + freelist :: non_neg_integer(), + fl_base :: non_neg_integer(), + cookie :: non_neg_integer(), + closed_properly :: non_neg_integer(), + type :: 'badtype' | type(), + version :: non_neg_integer(), + m :: non_neg_integer(), + next :: non_neg_integer(), + keypos :: keypos(), + no_objects :: non_neg_integer(), + no_keys :: non_neg_integer(), + min_no_slots :: non_neg_integer(), + max_no_slots :: non_neg_integer(), + no_colls :: 'undefined' | no_colls(), + hash_method :: non_neg_integer(), + read_md5 :: binary(), + has_md5 :: boolean(), + md5 :: binary(), + trailer :: non_neg_integer(), + eof :: non_neg_integer(), + n }). +-type delay() :: non_neg_integer(). +-type threshold() :: non_neg_integer(). +-type cache_parms() :: + {Delay :: delay(), % max time items are kept in RAM only, + % in milliseconds + Size :: threshold()}. % threshold size of cache, in bytes + %% Write Cache. -record(cache, { - cache, % [{Key,{Seq,Item}}], write cache, last item first - csize, % current size of the cached items - inserts, % upper limit on number of inserted keys - wrtime, % last write or update time - tsize, % threshold size of cache, in bytes - delay % max time items are kept in RAM only, in milliseconds + cache :: % write cache, last item first + [{Key :: term(), + {Seq :: non_neg_integer(), Item :: term()}}], + csize :: non_neg_integer(), % current size of the cached items + inserts :: % upper limit on number of inserted keys + non_neg_integer(), + wrtime :: 'undefined' | integer(), % last write or update time + tsize :: threshold(), % threshold size of cache + delay :: delay() % max time items are kept in RAM only }). +-type cache() :: #cache{}. diff --git a/lib/stdlib/src/dets_server.erl b/lib/stdlib/src/dets_server.erl index e3c9447c6f..b02d6ae159 100644 --- a/lib/stdlib/src/dets_server.erl +++ b/lib/stdlib/src/dets_server.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2001-2014. All Rights Reserved. +%% Copyright Ericsson AB 2001-2016. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. diff --git a/lib/stdlib/src/dets_sup.erl b/lib/stdlib/src/dets_sup.erl index e0087c58b4..43609cb8a1 100644 --- a/lib/stdlib/src/dets_sup.erl +++ b/lib/stdlib/src/dets_sup.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2002-2010. All Rights Reserved. +%% Copyright Ericsson AB 2002-2016. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. diff --git a/lib/stdlib/src/dets_utils.erl b/lib/stdlib/src/dets_utils.erl index 196158cd48..17f55ebdc2 100644 --- a/lib/stdlib/src/dets_utils.erl +++ b/lib/stdlib/src/dets_utils.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2001-2013. All Rights Reserved. +%% Copyright Ericsson AB 2001-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -20,13 +20,13 @@ -module(dets_utils). %% Utility functions common to several dets file formats. -%% To be used from dets, dets_v8 and dets_v9 only. +%% To be used from modules dets and dets_v9 only. -export([cmp/2, msort/1, mkeysort/2, mkeysearch/3, family/1]). -export([rename/2, pread/2, pread/4, ipread/3, pwrite/2, write/2, truncate/2, position/2, sync/1, open/2, truncate/3, fwrite/3, - write_file/2, position/3, position_close/3, pwrite/4, + write_file/2, position/3, position_close/3, pwrite/3, pread_close/4, read_n/2, pread_n/3, read_4/2]). -export([code_to_type/1, type_to_code/1]). @@ -44,8 +44,6 @@ all_allocated_as_list/1, find_allocated/4, find_next_allocated/3, log2/1, make_zeros/1]). --export([init_slots_from_old_file/2]). - -export([list_to_tree/1, tree_to_bin/5]). -compile({inline, [{sz2pos,1}, {adjust_addr,3}]}). @@ -308,12 +306,6 @@ position_close(Fd, FileName, Pos) -> OK -> OK end. -pwrite(Fd, FileName, Position, B) -> - case file:pwrite(Fd, Position, B) of - ok -> ok; - Error -> file_error(FileName, {error, Error}) - end. - pwrite(Fd, FileName, Bins) -> case file:pwrite(Fd, Bins) of ok -> @@ -395,7 +387,7 @@ corrupt_reason(Head, Reason0) -> corrupt(Head, Error) -> case get(verbose) of yes -> - error_logger:format("** dets: Corrupt table ~p: ~tp\n", + error_logger:format("** dets: Corrupt table ~tp: ~tp\n", [Head#head.name, Error]); _ -> ok end, @@ -478,20 +470,6 @@ new_cache({Delay, Size}) -> %%% Ullman. I think buddy systems were invented by Knuth, a long %%% time ago. -init_slots_from_old_file([{Slot,Addr} | T], Ftab) -> - init_slot(Slot+1,[{Slot,Addr} | T], Ftab); -init_slots_from_old_file([], Ftab) -> - Ftab. - -init_slot(_Slot,[], Ftab) -> - Ftab; % should never happen -init_slot(_Slot,[{_Addr,0}|T], Ftab) -> - init_slots_from_old_file(T, Ftab); -init_slot(Slot,[{_Slot1,Addr}|T], Ftab) -> - Stree = element(Slot, Ftab), - %% io:format("init_slot ~p:~p~n",[Slot, Addr]), - init_slot(Slot,T,setelement(Slot, Ftab, bplus_insert(Stree, Addr))). - %%% The free lists are kept in RAM, and written to the end of the file %%% from time to time. It is possible that a considerable amount of %%% memory is used for a fragmented file. @@ -747,6 +725,8 @@ all_allocated([{X,Y} | L], _X0, Y0, A) when Y0 < X -> all_allocated_as_list(Head) -> all_allocated_as_list(all(get_freelists(Head)), 0, Head#head.base, []). +-dialyzer({no_improper_lists, all_allocated_as_list/4}). + all_allocated_as_list([], _X0, _Y0, []) -> []; all_allocated_as_list([], _X0, _Y0, A) -> diff --git a/lib/stdlib/src/dets_v8.erl b/lib/stdlib/src/dets_v8.erl deleted file mode 100644 index 49126193b8..0000000000 --- a/lib/stdlib/src/dets_v8.erl +++ /dev/null @@ -1,1592 +0,0 @@ -%% -%% %CopyrightBegin% -%% -%% Copyright Ericsson AB 2001-2013. All Rights Reserved. -%% -%% Licensed under the Apache License, Version 2.0 (the "License"); -%% you may not use this file except in compliance with the License. -%% You may obtain a copy of the License at -%% -%% http://www.apache.org/licenses/LICENSE-2.0 -%% -%% Unless required by applicable law or agreed to in writing, software -%% distributed under the License is distributed on an "AS IS" BASIS, -%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -%% See the License for the specific language governing permissions and -%% limitations under the License. -%% -%% %CopyrightEnd% -%% --module(dets_v8). - -%% Dets files, implementation part. This module handles versions up to -%% and including 8(c). To be called from dets.erl only. - --export([mark_dirty/1, read_file_header/2, - check_file_header/2, do_perform_save/1, initiate_file/11, - init_freelist/2, fsck_input/4, - bulk_input/3, output_objs/4, write_cache/1, may_grow/3, - find_object/2, re_hash/2, slot_objs/2, scan_objs/8, - db_hash/2, no_slots/1, table_parameters/1]). - --export([file_info/1, v_segments/1]). - --export([cache_segps/3]). - -%% For backward compatibility. --export([sz2pos/1]). - --compile({inline, [{sz2pos,1},{scan_skip,7}]}). --compile({inline, [{skip_bytes,5}, {get_segp,1}]}). --compile({inline, [{wl_lookup,5}]}). --compile({inline, [{actual_seg_size,0}]}). - --include("dets.hrl"). - -%% The layout of the file is : -%% -%% bytes decsription -%% ---------------------- File header -%% 4 FreelistsPointer -%% 4 Cookie -%% 4 ClosedProperly (pos=8) -%% 4 Type (pos=12) -%% 4 Version (pos=16) -%% 4 M -%% 4 Next -%% 4 KeyPos -%% 4 NoObjects -%% 4 N -%% ------------------ end of file header -%% 4*8192 SegmentArray -%% ------------------ -%% 4*256 First segment -%% ----------------------------- This is BASE. -%% ??? Objects (free and alive) -%% 4*256 Second segment (2 kB now, due to a bug) -%% ??? Objects (free and alive) -%% ... more objects and segments ... -%% ----------------------------- -%% ??? Free lists -%% ----------------------------- -%% 4 File size, in bytes. - -%% The first slot (0) in the segment array always points to the -%% pre-allocated first segment. -%% Before we can find an object we must find the slot where the -%% object resides. Each slot is a (possibly empty) list (or chain) of -%% objects that hash to the same slot. If the value stored in the -%% slot is zero, the slot chain is empty. If the slot value is -%% non-zero, the value points to a position in the file where the -%% chain starts. Each object in a chain has the following layout: -%% -%% bytes decsription -%% -------------------- -%% 4 Pointer to the next object of the chain. -%% 4 Size of the object in bytes (Sz). -%% 4 Status (FREE or ACTIVE) -%% Sz Binary representing the object -%% -%% The status field is used while repairing a file (but not next or size). -%% -%%|---------------| -%%| head | -%%| | -%%| | -%%|_______________| -%%| |------| -%%|___seg ptr1____| | -%%| | | -%%|__ seg ptr 2___| | -%%| | | segment 1 -%%| .... | V _____________ -%% | | -%% | | -%% |___slot 0 ____| -%% | | -%% |___slot 1 ____|-----| -%% | | | -%% | ..... | | 1:st obj in slot 1 -%% V segment 1 -%% |-----------| -%% | next | -%% |___________| -%% | size | -%% |___________| -%% | status | -%% |___________| -%% | | -%% | | -%% | obj | -%% | | - -%%% -%%% File header -%%% - --define(HEADSZ, 40). % The size of the file header, in bytes. --define(SEGSZ, 256). % Size of a segment, in words. --define(SEGSZ_LOG2, 8). --define(SEGARRSZ, 8192). % Maximal number of segments. --define(SEGADDR(SegN), (?HEADSZ + (4 * (SegN)))). --define(BASE, ?SEGADDR((?SEGSZ + ?SEGARRSZ))). --define(MAXOBJS, (?SEGSZ * ?SEGARRSZ)). % 2 M objects - --define(SLOT2SEG(S), ((S) bsr ?SEGSZ_LOG2)). - -%% BIG is used for hashing. BIG must be greater than the maximum -%% number of slots, currently MAXOBJS. --define(BIG, 16#ffffff). - -%% Hard coded positions into the file header: --define(FREELIST_POS, 0). --define(CLOSED_PROPERLY_POS, 8). --define(D_POS, 20). --define(NO_OBJECTS_POS, (?D_POS + 12)). - -%% The version of a dets file is indicated by the ClosedProperly -%% field. Version 6 was used in the R1A release, and version 7 in the -%% R1B release up to and including the R3B01 release. Both version 6 -%% and version 7 indicate properly closed files by the value -%% CLOSED_PROPERLY. -%% -%% The current version, 8, has three sub-versions: -%% -%% - 8(a), indicated by the value CLOSED_PROPERLY (same as in versions 6 -%% and 7), introduced in R3B02; -%% - 8(b), indicated by the value CLOSED_PROPERLY2(_NEED_COMPACTING), -%% introduced in R5A and used up to and including R6A; -%% - 8(c), indicated by the value CLOSED_PROPERLY_NEW_HASH(_NEED_COMPACTING), -%% in use since R6B. -%% -%% The difference between the 8(a) and the 8(b) versions is the format -%% used for free lists saved on dets files. -%% The 8(c) version uses a different hashing algorithm, erlang:phash -%% (former versions use erlang:hash). -%% Version 8(b) files are only converted to version 8(c) if repair is -%% done, so we need compatibility with 8(b) for a _long_ time. -%% -%% There are known bugs due to the fact that keys and objects are -%% sometimes compared (==) and sometimes matched (=:=). The version -%% used by default (9, see dets_v9.erl) does not have this problem. - --define(NOT_PROPERLY_CLOSED,0). --define(CLOSED_PROPERLY,1). --define(CLOSED_PROPERLY2,2). --define(CLOSED_PROPERLY2_NEED_COMPACTING,3). --define(CLOSED_PROPERLY_NEW_HASH,4). --define(CLOSED_PROPERLY_NEW_HASH_NEED_COMPACTING,5). - --define(FILE_FORMAT_VERSION, 8). --define(CAN_BUMP_BY_REPAIR, [6, 7]). --define(CAN_CONVERT_FREELIST, [8]). - -%%% -%%% Object header (next, size, status). -%%% - --define(OHDSZ, 12). % The size of the object header, in bytes. --define(STATUS_POS, 8). % Position of the status field. - -%% The size of each object is a multiple of 16. -%% BUMP is used when repairing files. --define(BUMP, 16). - --define(ReadAhead, 512). - -%%-define(DEBUGF(X,Y), io:format(X, Y)). --define(DEBUGF(X,Y), void). - -%% -> ok | throw({NewHead,Error}) -mark_dirty(Head) -> - Dirty = [{?CLOSED_PROPERLY_POS, <<?NOT_PROPERLY_CLOSED:32>>}], - {_NewHead, ok} = dets_utils:pwrite(Head, Dirty), - ok = dets_utils:sync(Head), - {ok, _Pos} = dets_utils:position(Head, Head#head.freelists_p), - ok = dets_utils:truncate(Head, cur). - -%% -> {ok, head()} | throw(Error) -initiate_file(Fd, Tab, Fname, Type, Kp, MinSlots, MaxSlots, - Ram, CacheSz, Auto, _DoInitSegments) -> - Freelist = 0, - Cookie = ?MAGIC, - ClosedProperly = ?NOT_PROPERLY_CLOSED, % immediately overwritten - Version = ?FILE_FORMAT_VERSION, - Factor = est_no_segments(MinSlots), - N = 0, - M = Next = ?SEGSZ * Factor, - NoObjects = 0, - dets_utils:pwrite(Fd, Fname, 0, - <<Freelist:32, - Cookie:32, - ClosedProperly:32, - (dets_utils:type_to_code(Type)):32, - Version:32, - M:32, - Next:32, - Kp:32, - NoObjects:32, - N:32, - 0:(?SEGARRSZ*4)/unit:8, % Initialize SegmentArray - 0:(?SEGSZ*4)/unit:8>>), % Initialize first segment - %% We must set the first slot of the segment pointer array to - %% point to the first segment - Pos = ?SEGADDR(0), - SegP = (?HEADSZ + (4 * ?SEGARRSZ)), - dets_utils:pwrite(Fd, Fname, Pos, <<SegP:32>>), - segp_cache(Pos, SegP), - - Ftab = dets_utils:init_alloc(?BASE), - H0 = #head{freelists=Ftab, fptr = Fd, base = ?BASE}, - {H1, Ws} = init_more_segments(H0, 1, Factor, undefined, []), - - %% This is not optimal but simple: always initiate the segments. - dets_utils:pwrite(Fd, Fname, Ws), - - %% Return a new nice head structure - Head = #head{ - m = M, - m2 = M * 2, - next = Next, - fptr = Fd, - no_objects = NoObjects, - n = N, - type = Type, - update_mode = dirty, - freelists = H1#head.freelists, - auto_save = Auto, - hash_bif = phash, - keypos = Kp, - min_no_slots = Factor * ?SEGSZ, - max_no_slots = no_segs(MaxSlots) * ?SEGSZ, - - ram_file = Ram, - filename = Fname, - name = Tab, - cache = dets_utils:new_cache(CacheSz), - version = Version, - bump = ?BUMP, - base = ?BASE, - mod = ?MODULE - }, - {ok, Head}. - -est_no_segments(MinSlots) when 1 + ?SLOT2SEG(MinSlots) > ?SEGARRSZ -> - ?SEGARRSZ; -est_no_segments(MinSlots) -> - 1 + ?SLOT2SEG(MinSlots). - -init_more_segments(Head, SegNo, Factor, undefined, Ws) when SegNo < Factor -> - init_more_segments(Head, SegNo, Factor, seg_zero(), Ws); -init_more_segments(Head, SegNo, Factor, SegZero, Ws) when SegNo < Factor -> - {NewHead, W} = allocate_segment(Head, SegZero, SegNo), - init_more_segments(NewHead, SegNo+1, Factor, SegZero, W++Ws); -init_more_segments(Head, _SegNo, _Factor, _SegZero, Ws) -> - {Head, Ws}. - -allocate_segment(Head, SegZero, SegNo) -> - %% may throw error: - {NewHead, Segment, _} = dets_utils:alloc(Head, 4 * ?SEGSZ), - InitSegment = {Segment, SegZero}, - Pos = ?SEGADDR(SegNo), - segp_cache(Pos, Segment), - SegPointer = {Pos, <<Segment:32>>}, - {NewHead, [InitSegment, SegPointer]}. - -%% Read free lists (using a Buddy System) from file. -init_freelist(Head, {convert_freelist,_Version}) -> - %% This function converts the saved freelist of the form - %% [{Slot1,Addr1},{Addr1,Addr2},...,{AddrN,0},{Slot2,Addr},...] - %% i.e each slot is a linked list which ends with a 0. - %% This is stored in a bplus_tree per Slot. - %% Each Slot is a position in a tuple. - - Ftab = dets_utils:empty_free_lists(), - Pos = Head#head.freelists_p, - case catch prterm(Head, Pos, ?OHDSZ) of - {0, _Sz, Term} -> - FreeList1 = lists:reverse(Term), - FreeList = dets_utils:init_slots_from_old_file(FreeList1, Ftab), - Head#head{freelists = FreeList, base = ?BASE}; - _ -> - throw({error, {bad_freelists, Head#head.filename}}) - end; -init_freelist(Head, _) -> - %% bplus_tree stored as is - Pos = Head#head.freelists_p, - case catch prterm(Head, Pos, ?OHDSZ) of - {0, _Sz, Term} -> - Head#head{freelists = Term, base = ?BASE}; - _ -> - throw({error, {bad_freelists, Head#head.filename}}) - end. - -%% -> {ok, Fd, fileheader()} | throw(Error) -read_file_header(Fd, FileName) -> - {ok, Bin} = dets_utils:pread_close(Fd, FileName, 0, ?HEADSZ), - [Freelist, Cookie, CP, Type2, Version, M, Next, Kp, NoObjects, N] = - bin2ints(Bin), - {ok, EOF} = dets_utils:position_close(Fd, FileName, eof), - {ok, <<FileSize:32>>} = dets_utils:pread_close(Fd, FileName, EOF-4, 4), - FH = #fileheader{freelist = Freelist, - fl_base = ?BASE, - cookie = Cookie, - closed_properly = CP, - type = dets_utils:code_to_type(Type2), - version = Version, - m = M, - next = Next, - keypos = Kp, - no_objects = NoObjects, - min_no_slots = ?DEFAULT_MIN_NO_SLOTS, - max_no_slots = ?DEFAULT_MAX_NO_SLOTS, - trailer = FileSize, - eof = EOF, - n = N, - mod = ?MODULE}, - {ok, Fd, FH}. - -%% -> {ok, head(), ExtraInfo} | {error, Reason} (Reason lacking file name) -%% ExtraInfo = {convert_freelist, Version} | true | need_compacting -check_file_header(FH, Fd) -> - Test = - if - FH#fileheader.cookie =/= ?MAGIC -> - {error, not_a_dets_file}; - FH#fileheader.type =:= badtype -> - {error, invalid_type_code}; - FH#fileheader.version =/= ?FILE_FORMAT_VERSION -> - case lists:member(FH#fileheader.version, - ?CAN_BUMP_BY_REPAIR) of - true -> - {error, version_bump}; - false -> - {error, bad_version} - end; - FH#fileheader.trailer =/= FH#fileheader.eof -> - {error, not_closed}; - FH#fileheader.closed_properly =:= ?CLOSED_PROPERLY -> - case lists:member(FH#fileheader.version, - ?CAN_CONVERT_FREELIST) of - true -> - {ok, {convert_freelist, FH#fileheader.version}, hash}; - false -> - {error, not_closed} % should not happen - end; - FH#fileheader.closed_properly =:= ?CLOSED_PROPERLY2 -> - {ok, true, hash}; - FH#fileheader.closed_properly =:= - ?CLOSED_PROPERLY2_NEED_COMPACTING -> - {ok, need_compacting, hash}; - FH#fileheader.closed_properly =:= ?CLOSED_PROPERLY_NEW_HASH -> - {ok, true, phash}; - FH#fileheader.closed_properly =:= - ?CLOSED_PROPERLY_NEW_HASH_NEED_COMPACTING -> - {ok, need_compacting, phash}; - FH#fileheader.closed_properly =:= ?NOT_PROPERLY_CLOSED -> - {error, not_closed}; - FH#fileheader.closed_properly > - ?CLOSED_PROPERLY_NEW_HASH_NEED_COMPACTING -> - {error, not_closed}; - true -> - {error, not_a_dets_file} - end, - case Test of - {ok, ExtraInfo, HashAlg} -> - H = #head{ - m = FH#fileheader.m, - m2 = FH#fileheader.m * 2, - next = FH#fileheader.next, - fptr = Fd, - no_objects= FH#fileheader.no_objects, - n = FH#fileheader.n, - type = FH#fileheader.type, - update_mode = saved, - auto_save = infinity, % not saved on file - fixed = false, % not saved on file - freelists_p = FH#fileheader.freelist, - hash_bif = HashAlg, - keypos = FH#fileheader.keypos, - min_no_slots = FH#fileheader.min_no_slots, - max_no_slots = FH#fileheader.max_no_slots, - version = ?FILE_FORMAT_VERSION, - mod = ?MODULE, - bump = ?BUMP, - base = FH#fileheader.fl_base}, - {ok, H, ExtraInfo}; - Error -> - Error - end. - -cache_segps(Fd, FileName, M) -> - NSegs = no_segs(M), - {ok, Bin} = dets_utils:pread_close(Fd, FileName, ?HEADSZ, 4 * NSegs), - Fun = fun(S, P) -> segp_cache(P, S), P+4 end, - lists:foldl(Fun, ?HEADSZ, bin2ints(Bin)). - -no_segs(NoSlots) -> - ?SLOT2SEG(NoSlots - 1) + 1. - -bin2ints(<<Int:32, B/binary>>) -> - [Int | bin2ints(B)]; -bin2ints(<<>>) -> - []. - -%%% -%%% Repair, conversion and initialization of a dets file. -%%% - -bulk_input(Head, InitFun, Cntrs) -> - bulk_input(Head, InitFun, Cntrs, make_ref()). - -bulk_input(Head, InitFun, Cntrs, Ref) -> - fun(close) -> - ok; - (read) -> - case catch {Ref, InitFun(read)} of - {Ref, end_of_input} -> - end_of_input; - {Ref, {L0, NewInitFun}} when is_list(L0), - is_function(NewInitFun) -> - Kp = Head#head.keypos, - case catch bulk_objects(L0, Head, Cntrs, Kp, []) of - {'EXIT', _Error} -> - _ = (catch NewInitFun(close)), - {error, invalid_objects_list}; - L -> - {L, bulk_input(Head, NewInitFun, Cntrs, Ref)} - end; - {Ref, Value} -> - {error, {init_fun, Value}}; - Error -> - throw({thrown, Error}) - end - end. - -bulk_objects([T | Ts], Head, Cntrs, Kp, L) -> - BT = term_to_binary(T), - Sz = byte_size(BT), - LogSz = sz2pos(Sz+?OHDSZ), - count_object(Cntrs, LogSz), - Key = element(Kp, T), - bulk_objects(Ts, Head, Cntrs, Kp, [make_object(Head, Key, LogSz, BT) | L]); -bulk_objects([], _Head, _Cntrs, _Kp, L) -> - L. - --define(FSCK_SEGMENT, 10000). - --define(DCT(D, CT), [D | CT]). - --define(VNEW(N, E), erlang:make_tuple(N, E)). --define(VSET(I, V, E), setelement(I, V, E)). --define(VGET(I, V), element(I, V)). - -%% OldVersion not used, assuming later versions have been converted already. -output_objs(OldVersion, Head, SlotNumbers, Cntrs) -> - fun(close) -> - {ok, 0, Head}; - ([]) -> - output_objs(OldVersion, Head, SlotNumbers, Cntrs); - (L) -> - %% Descending sizes. - Count = lists:sort(ets:tab2list(Cntrs)), - RCount = lists:reverse(Count), - NoObjects = lists:foldl(fun({_Sz,No}, A) -> A + No end, 0, Count), - {_, MinSlots, _} = SlotNumbers, - if - %% Using number of objects for bags and duplicate bags - %% is not ideal; number of (unique) keys should be - %% used instead. The effect is that there will be more - %% segments than "necessary". - MinSlots =/= bulk_init, - abs(?SLOT2SEG(NoObjects) - ?SLOT2SEG(MinSlots)) > 5, - (NoObjects < ?MAXOBJS) -> - {try_again, NoObjects}; - true -> - Head1 = Head#head{no_objects = NoObjects}, - SegSz = actual_seg_size(), - {_, End, _} = dets_utils:alloc(Head, SegSz-1), - %% Now {LogSize,NoObjects} in Cntrs is replaced by - %% {LogSize,Position,{FileName,FileDescriptor},NoObjects}. - {Head2, CT} = allocate_all_objects(Head1, RCount, Cntrs), - [E | Es] = bin2term(L, []), - {NE, Acc, DCT1} = - output_slots(E, Es, [E], Head2, ?DCT(0, CT)), - NDCT = write_all_sizes(DCT1, Cntrs), - Max = ets:info(Cntrs, size), - output_objs2(NE, Acc, Head2, Cntrs, NDCT, End, Max,Max) - end - end. - -output_objs2(E, Acc, Head, Cntrs, DCT, End, 0, MaxNoChunks) -> - NDCT = write_all_sizes(DCT, Cntrs), - output_objs2(E, Acc, Head, Cntrs, NDCT, End, MaxNoChunks, MaxNoChunks); -output_objs2(E, Acc, Head, Cntrs, DCT, End, ChunkI, MaxNoChunks) -> - fun(close) -> - DCT1 = output_slot(Acc, Head, DCT), - NDCT = write_all_sizes(DCT1, Cntrs), - ?DCT(NoDups, CT) = NDCT, - [SegAddr | []] = ?VGET(tuple_size(CT), CT), - FinalZ = End - SegAddr, - [{?FSCK_SEGMENT, _, {FileName, Fd}, _}] = - ets:lookup(Cntrs, ?FSCK_SEGMENT), - ok = dets_utils:fwrite(Fd, FileName, - dets_utils:make_zeros(FinalZ)), - NewHead = Head#head{no_objects = Head#head.no_objects - NoDups}, - {ok, NoDups, NewHead}; - (L) -> - Es = bin2term(L, []), - {NE, NAcc, NDCT} = output_slots(E, Es, Acc, Head, DCT), - output_objs2(NE, NAcc, Head, Cntrs, NDCT, End, - ChunkI-1, MaxNoChunks) - end. - -%% By allocating bigger objects before smaller ones, holes in the -%% buddy system memory map are avoided. Unfortunately, the segments -%% are always allocated first, so if there are objects bigger than a -%% segment, there is a hole to handle. (Haven't considered placing the -%% segments among other objects of the same size.) -allocate_all_objects(Head, Count, Cntrs) -> - SegSize = actual_seg_size(), - {Head1, HSz, HN, HA} = alloc_hole(Count, Head, SegSize), - {Max, _} = hd(Count), - CT = ?VNEW(Max+1, not_used), - {Head2, NCT} = allocate_all(Head1, Count, Cntrs, CT), - Head3 = free_hole(Head2, HSz, HN, HA), - {Head3, NCT}. - -alloc_hole([{LSize,_} | _], Head, SegSz) when ?POW(LSize-1) > SegSz -> - {_, SegAddr, _} = dets_utils:alloc(Head, SegSz-1), - Size = ?POW(LSize-1)-1, - {_, Addr, _} = dets_utils:alloc(Head, Size), - N = (Addr - SegAddr) div SegSz, - Head1 = dets_utils:alloc_many(Head, SegSz, N, SegAddr), - {Head1, SegSz-1, N, SegAddr}; -alloc_hole(_Count, Head, _SegSz) -> - {Head, 0, 0, 0}. - -free_hole(Head, _Size, 0, _Addr) -> - Head; -free_hole(Head, Size, N, Addr) -> - {Head1, _} = dets_utils:free(Head, Addr, Size), - free_hole(Head1, Size, N-1, Addr+Size+1). - -%% One (temporary) file for each buddy size, write all objects of that -%% size to the file. -allocate_all(Head, [{LSize,NoObjects} | Count], Cntrs, CT) -> - Size = ?POW(LSize-1)-1, - {_Head, Addr, _} = dets_utils:alloc(Head, Size), - NewHead = dets_utils:alloc_many(Head, Size+1, NoObjects, Addr), - {FileName, Fd} = temp_file(Head, LSize), - true = ets:insert(Cntrs, {LSize, Addr, {FileName, Fd}, NoObjects}), - NCT = ?VSET(LSize, CT, [Addr | []]), - allocate_all(NewHead, Count, Cntrs, NCT); -allocate_all(Head, [], Cntrs, CT) -> - %% Note that space for the segments has been allocated already. - %% And one file for the segments... - {FileName, Fd} = temp_file(Head, ?FSCK_SEGMENT), - Addr = ?SEGADDR(?SEGARRSZ), - true = ets:insert(Cntrs, {?FSCK_SEGMENT, Addr, {FileName, Fd}, 0}), - NCT = ?VSET(tuple_size(CT), CT, [Addr | []]), - {Head, NCT}. - -temp_file(Head, N) -> - TmpName = lists:concat([Head#head.filename, '.', N]), - {ok, Fd} = dets_utils:open(TmpName, [raw, binary, write]), - {TmpName, Fd}. - -bin2term([<<Slot:32, LogSize:8, BinTerm/binary>> | BTs], L) -> - bin2term(BTs, [{Slot, LogSize, BinTerm} | L]); -bin2term([], L) -> - lists:reverse(L). - -write_all_sizes(?DCT(D, CT), Cntrs) -> - ?DCT(D, write_sizes(1, tuple_size(CT), CT, Cntrs)). - -write_sizes(Sz, Sz, CT, Cntrs) -> - write_size(Sz, ?FSCK_SEGMENT, CT, Cntrs); -write_sizes(Sz, MaxSz, CT, Cntrs) -> - NCT = write_size(Sz, Sz, CT, Cntrs), - write_sizes(Sz+1, MaxSz, NCT, Cntrs). - -write_size(Sz, I, CT, Cntrs) -> - case ?VGET(Sz, CT) of - not_used -> - CT; - [Addr | L] -> - {FileName, Fd} = ets:lookup_element(Cntrs, I, 3), - case file:write(Fd, lists:reverse(L)) of - ok -> - ?VSET(Sz, CT, [Addr | []]); - Error -> - dets_utils:file_error(FileName, Error) - end - end. - -output_slots(E, [E1 | Es], Acc, Head, DCT) - when element(1, E) =:= element(1, E1) -> - output_slots(E1, Es, [E1 | Acc], Head, DCT); -output_slots(_E, [E | L], Acc, Head, DCT) -> - NDCT = output_slot(Acc, Head, DCT), - output_slots(E, L, [E], Head, NDCT); -output_slots(E, [], Acc, _Head, DCT) -> - {E, Acc, DCT}. - -output_slot([E], _Head, ?DCT(D, CT)) -> - ?DCT(D, output_slot([{foo, E}], 0, foo, CT)); -output_slot(Es0, Head, ?DCT(D, CT)) -> - Kp = Head#head.keypos, - Fun = fun({_Slot, _LSize, BinTerm} = E) -> - Key = element(Kp, binary_to_term(BinTerm)), - {Key, E} - end, - Es = lists:map(Fun, Es0), - NEs = case Head#head.type of - set -> - [{Key0,_} = E | L0] = lists:sort(Es), - choose_one(lists:sort(L0), Key0, [E]); - bag -> - lists:usort(Es); - duplicate_bag -> - lists:sort(Es) - end, - Dups = D + length(Es) - length(NEs), - ?DCT(Dups, output_slot(NEs, 0, foo, CT)). - -choose_one([{Key,_} | Es], Key, L) -> - choose_one(Es, Key, L); -choose_one([{Key,_} = E | Es], _Key, L) -> - choose_one(Es, Key, [E | L]); -choose_one([], _Key, L) -> - L. - -output_slot([E | Es], Next, _Slot, CT) -> - {_Key, {Slot, LSize, BinTerm}} = E, - Size = byte_size(BinTerm), - Size2 = ?POW(LSize-1), - Pad = <<0:(Size2-Size-?OHDSZ)/unit:8>>, - BinObject = [<<Next:32, Size:32, ?ACTIVE:32>>, BinTerm | Pad], - [Addr | L] = ?VGET(LSize, CT), - NCT = ?VSET(LSize, CT, [Addr+Size2 | [BinObject | L]]), - output_slot(Es, Addr, Slot, NCT); -output_slot([], Next, Slot, CT) -> - I = tuple_size(CT), - [Addr | L] = ?VGET(I, CT), - {Pos, _} = slot_position(Slot), - NoZeros = Pos - Addr, - BinObject = if - NoZeros > 100 -> - [dets_utils:make_zeros(NoZeros) | <<Next:32>>]; - true -> - <<0:NoZeros/unit:8,Next:32>> - end, - Size = NoZeros+4, - ?VSET(I, CT, [Addr+Size | [BinObject | L]]). - -%% Does not close Fd. -fsck_input(Head, Fd, Cntrs, _FileHeader) -> - %% The file is not compressed, so the object size cannot exceed - %% the filesize, for all objects. - MaxSz = case file:position(Fd, eof) of - {ok, Pos} -> - Pos; - _ -> - (1 bsl 32) - 1 - end, - State0 = fsck_read(?BASE, Fd, []), - fsck_input1(Head, State0, Fd, MaxSz, Cntrs). - -fsck_input1(Head, State, Fd, MaxSz, Cntrs) -> - fun(close) -> - ok; - (read) -> - case State of - done -> - end_of_input; - {done, L} -> - R = count_input(Cntrs, L, []), - {R, fsck_input1(Head, done, Fd, MaxSz, Cntrs)}; - {cont, L, Bin, Pos} -> - R = count_input(Cntrs, L, []), - FR = fsck_objs(Bin, Head#head.keypos, Head, []), - NewState = fsck_read(FR, Pos, Fd, MaxSz, Head), - {R, fsck_input1(Head, NewState, Fd, MaxSz, Cntrs)} - end - end. - -%% The ets table Cntrs is used for counting objects per size. -count_input(Cntrs, [[LogSz | B] | Ts], L) -> - count_object(Cntrs, LogSz), - count_input(Cntrs, Ts, [B | L]); -count_input(_Cntrs, [], L) -> - L. - -count_object(Cntrs, LogSz) -> - case catch ets:update_counter(Cntrs, LogSz, 1) of - N when is_integer(N) -> ok; - _Badarg -> true = ets:insert(Cntrs, {LogSz, 1}) - end. - -fsck_read(Pos, F, L) -> - case file:position(F, Pos) of - {ok, _} -> - read_more_bytes(<<>>, 0, Pos, F, L); - _Error -> - {done, L} - end. - -fsck_read({more, Bin, Sz, L}, Pos, F, MaxSz, Head) when Sz > MaxSz -> - FR = skip_bytes(Bin, ?BUMP, Head#head.keypos, Head, L), - fsck_read(FR, Pos, F, MaxSz, Head); -fsck_read({more, Bin, Sz, L}, Pos, F, _MaxSz, _Head) -> - read_more_bytes(Bin, Sz, Pos, F, L); -fsck_read({new, Skip, L}, Pos, F, _MaxSz, _Head) -> - NewPos = Pos + Skip, - fsck_read(NewPos, F, L). - -read_more_bytes(B, Min, Pos, F, L) -> - Max = if - Min < ?CHUNK_SIZE -> ?CHUNK_SIZE; - true -> Min - end, - case dets_utils:read_n(F, Max) of - eof -> - {done, L}; - Bin -> - NewPos = Pos + byte_size(Bin), - {cont, L, list_to_binary([B, Bin]), NewPos} - end. - -fsck_objs(Bin = <<_N:32, Sz:32, Status:32, Tail/binary>>, Kp, Head, L) -> - if - Status =:= ?ACTIVE -> - case Tail of - <<BinTerm:Sz/binary, Tail2/binary>> -> - case catch element(Kp, binary_to_term(BinTerm)) of - {'EXIT', _} -> - skip_bytes(Bin, ?BUMP, Kp, Head, L); - Key -> - LogSz = sz2pos(Sz+?OHDSZ), - Obj = make_object(Head, Key, LogSz, BinTerm), - NL = [[LogSz | Obj] | L], - Skip = ?POW(LogSz-1) - Sz - ?OHDSZ, - skip_bytes(Tail2, Skip, Kp, Head, NL) - end; - _ -> - {more, Bin, Sz, L} - end; - true -> - skip_bytes(Bin, ?BUMP, Kp, Head, L) - end; -fsck_objs(Bin, _Kp, _Head, L) -> - {more, Bin, 0, L}. - -%% Version 8 has to know about version 9. -make_object(Head, Key, _LogSz, BT) when Head#head.version =:= 9 -> - Slot = dets_v9:db_hash(Key, Head), - <<Slot:32, BT/binary>>; -make_object(Head, Key, LogSz, BT) -> - Slot = db_hash(Key, Head), - <<Slot:32, LogSz:8, BT/binary>>. - -%% Inlined. -skip_bytes(Bin, Skip, Kp, Head, L) -> - case Bin of - <<_:Skip/binary, Tail/binary>> -> - fsck_objs(Tail, Kp, Head, L); - _ -> - {new, Skip - byte_size(Bin), L} - end. - -%% -> {NewHead, ok} | throw({Head, Error}) -do_perform_save(H) -> - FL = dets_utils:get_freelists(H), - B = term_to_binary(FL), - Size = byte_size(B), - ?DEBUGF("size of freelist = ~p~n", [Size]), - ?DEBUGF("head.m = ~p~n", [H#head.m]), - ?DEBUGF("head.no_objects = ~p~n", [H#head.no_objects]), - - {ok, Pos} = dets_utils:position(H, eof), - H1 = H#head{freelists_p = Pos}, - W1 = {?FREELIST_POS, <<Pos:32>>}, - W2 = {Pos, [<<0:32, Size:32, ?FREE:32>>, B]}, - - W3 = {?D_POS, <<(H1#head.m):32, - (H1#head.next):32, - (H1#head.keypos):32, - (H1#head.no_objects):32, - (H1#head.n):32>>}, - {ClosedProperly, ClosedProperlyNeedCompacitng} = - case H1#head.hash_bif of - hash -> - {?CLOSED_PROPERLY2, ?CLOSED_PROPERLY2_NEED_COMPACTING}; - phash -> - {?CLOSED_PROPERLY_NEW_HASH, - ?CLOSED_PROPERLY_NEW_HASH_NEED_COMPACTING} - end, - W4 = - if - Size > 1000, Size > H1#head.no_objects -> - {?CLOSED_PROPERLY_POS, - <<ClosedProperlyNeedCompacitng:32>>}; - true -> - {?CLOSED_PROPERLY_POS, <<ClosedProperly:32>>} - end, - W5 = {?FILE_FORMAT_VERSION_POS, <<?FILE_FORMAT_VERSION:32>>}, - {H2, ok} = dets_utils:pwrite(H1, [W1,W2,W3,W4,W5]), - {ok, Pos2} = dets_utils:position(H2, eof), - ?DEBUGF("Writing file size ~p, eof at ~p~n", [Pos2+4, Pos2]), - dets_utils:pwrite(H2, [{Pos2, <<(Pos2 + 4):32>>}]). - -%% -> [term()] | throw({Head, Error}) -slot_objs(H, Slot) when Slot >= H#head.next -> - '$end_of_table'; -slot_objs(H, Slot) -> - {_Pos, Chain} = chain(H, Slot), - collect_chain(H, Chain). - -collect_chain(_H, 0) -> []; -collect_chain(H, Pos) -> - {Next, _Sz, Term} = prterm(H, Pos, ?ReadAhead), - [Term | collect_chain(H, Next)]. - -db_hash(Key, Head) -> - H = h(Key, Head#head.hash_bif), - Hash = H rem Head#head.m, - if - Hash < Head#head.n -> - H rem (Head#head.m2); % H rem (2 * m) - true -> - Hash - end. - -h(I, phash) -> erlang:phash(I, ?BIG) - 1; -h(I, HF) -> erlang:HF(I, ?BIG) - 1. %% stupid BIF has 1 counts. - -no_slots(_Head) -> - undefined. - -table_parameters(_Head) -> - undefined. - -%% Re-hashing a segment, starting with SlotStart. -%% -%% On the average, half of the objects of the chain are put into a new -%% chain. If the slot of the old chain is i, then the slot of the new -%% chain is i+m. -%% Note that the insertion of objects into the new chain is simplified -%% by the fact that the chains are not sorted on key, which means that -%% each moved object can be inserted first in the new chain. -%% (It is also a fact that the objects with the same key are not sorted.) -%% -%% -> {ok, Writes} | throw({Head, Error}) -re_hash(Head, SlotStart) -> - {SlotPos, _4} = slot_position(SlotStart), - {ok, Bin} = dets_utils:pread(Head, SlotPos, 4*?SEGSZ, 0), - {Read, Cs} = split_bin(SlotPos, Bin, [], []), - re_hash_read(Head, [], Read, Cs). - -split_bin(Pos, <<P:32, B/binary>>, R, Cs) -> - if - P =:= 0 -> - split_bin(Pos+4, B, R, Cs); - true -> - split_bin(Pos+4, B, [{P,?ReadAhead} | R], [[Pos] | Cs]) - end; -split_bin(_Pos, <<>>, R, Cs) -> - {R, Cs}. - -re_hash_read(Head, Cs, R, RCs) -> - {ok, Bins} = dets_utils:pread(R, Head), - re_hash_read(Head, R, RCs, Bins, Cs, [], []). - -re_hash_read(Head, [{Pos, Size} | Ps], [C | Cs], - [<<Next:32, Sz:32, _Status:32, Bin0/binary>> | Bins], - DoneCs, R, RCs) -> - case byte_size(Bin0) of - BinSz when BinSz >= Sz -> - case catch binary_to_term(Bin0) of - {'EXIT', _Error} -> - throw(dets_utils:corrupt_reason(Head, bad_object)); - Term -> - Key = element(Head#head.keypos, Term), - New = h(Key, Head#head.hash_bif) rem Head#head.m2, - NC = case New >= Head#head.m of - true -> [{Pos,New} | C]; - false -> [Pos | C] - end, - if - Next =:= 0 -> - NDoneCs = [NC | DoneCs], - re_hash_read(Head, Ps, Cs, Bins, NDoneCs, R, RCs); - true -> - NR = [{Next,?ReadAhead} | R], - NRCs = [NC | RCs], - re_hash_read(Head, Ps, Cs, Bins, DoneCs, NR, NRCs) - end - end; - BinSz when Size =:= BinSz+?OHDSZ -> - NR = [{Pos, Sz+?OHDSZ} | R], - re_hash_read(Head, Ps, Cs, Bins, DoneCs, NR, [C | RCs]); - _BinSz -> - throw({Head, {error, {premature_eof, Head#head.filename}}}) - end; -re_hash_read(Head, [], [], [], Cs, [], []) -> - re_hash_traverse_chains(Cs, Head, [], [], []); -re_hash_read(Head, [], [], [], Cs, R, RCs) -> - re_hash_read(Head, Cs, R, RCs). - -re_hash_traverse_chains([C | Cs], Head, Rs, Ns, Ws) -> - case re_hash_find_new(C, Rs, start, start) of - false -> - re_hash_traverse_chains(Cs, Head, Rs, Ns, Ws); - {NRs, FirstNew, LastNew} -> - LastInNew = case C of - [{_,_} | _] -> true; - _ -> false - end, - N = {FirstNew, LastNew, LastInNew}, - NWs = re_hash_link(C, start, start, start, Ws), - re_hash_traverse_chains(Cs, Head, NRs, [N | Ns], NWs) - end; -re_hash_traverse_chains([], Head, Rs, Ns, Ws) -> - {ok, Bins} = dets_utils:pread(Rs, Head), - {ok, insert_new(Rs, Bins, Ns, Ws)}. - -re_hash_find_new([{Pos,NewSlot} | C], R, start, start) -> - {SPos, _4} = slot_position(NewSlot), - re_hash_find_new(C, [{SPos,4} | R], Pos, Pos); -re_hash_find_new([{Pos,_SPos} | C], R, _FirstNew, LastNew) -> - re_hash_find_new(C, R, Pos, LastNew); -re_hash_find_new([_Pos | C], R, FirstNew, LastNew) -> - re_hash_find_new(C, R, FirstNew, LastNew); -re_hash_find_new([], _R, start, start) -> - false; -re_hash_find_new([], R, FirstNew, LastNew) -> - {R, FirstNew, LastNew}. - -re_hash_link([{Pos,_SPos} | C], LastOld, start, _LastInNew, Ws) -> - re_hash_link(C, LastOld, Pos, true, Ws); -re_hash_link([{Pos,_SPos} | C], LastOld, LastNew, false, Ws) -> - re_hash_link(C, LastOld, Pos, true, [{Pos,<<LastNew:32>>} | Ws]); -re_hash_link([{Pos,_SPos} | C], LastOld, _LastNew, LastInNew, Ws) -> - re_hash_link(C, LastOld, Pos, LastInNew, Ws); -re_hash_link([Pos | C], start, LastNew, true, Ws) -> - re_hash_link(C, Pos, LastNew, false, [{Pos,<<0:32>>} | Ws]); -re_hash_link([Pos | C], LastOld, LastNew, true, Ws) -> - re_hash_link(C, Pos, LastNew, false, [{Pos,<<LastOld:32>>} | Ws]); -re_hash_link([Pos | C], _LastOld, LastNew, LastInNew, Ws) -> - re_hash_link(C, Pos, LastNew, LastInNew, Ws); -re_hash_link([], _LastOld, _LastNew, _LastInNew, Ws) -> - Ws. - -insert_new([{NewSlotPos,_4} | Rs], [<<P:32>> = PB | Bins], [N | Ns], Ws) -> - {FirstNew, LastNew, LastInNew} = N, - Ws1 = case P of - 0 when LastInNew -> - Ws; - 0 -> - [{LastNew, <<0:32>>} | Ws]; - _ -> - [{LastNew, PB} | Ws] - end, - NWs = [{NewSlotPos, <<FirstNew:32>>} | Ws1], - insert_new(Rs, Bins, Ns, NWs); -insert_new([], [], [], Ws) -> - Ws. - -%% When writing the cache, a 'work list' is first created: -%% WorkList = [{Key, {Delete,Lookup,[Inserted]}}] -%% Delete = keep | delete -%% Lookup = skip | lookup -%% Inserted = {object(), No} -%% No = integer() -%% If No =< 0 then there will be -No instances of object() on the file -%% when the cache has been written. If No > 0 then No instances of -%% object() will be added to the file. -%% If Delete has the value 'delete', then all objects with the key Key -%% have been deleted. (This could be viewed as a shorthand for {Object,0} -%% for each object Object on the file not mentioned in some Inserted.) -%% If Lookup has the value 'lookup', all objects with the key Key will -%% be returned. -%% - -%% -> {NewHead, [LookedUpObject], pwrite_list()} | throw({NewHead, Error}) -write_cache(Head) -> - #head{cache = C, type = Type} = Head, - case dets_utils:is_empty_cache(C) of - true -> {Head, [], []}; - false -> - {NewC, _MaxInserts, PerKey} = dets_utils:reset_cache(C), - %% NoInsertedKeys is an upper limit on the number of new keys. - {WL, NoInsertedKeys} = make_wl(PerKey, Type), - Head1 = Head#head{cache = NewC}, - case may_grow(Head1, NoInsertedKeys, once) of - {Head2, ok} -> - eval_work_list(Head2, WL); - HeadError -> - throw(HeadError) - end - end. - -make_wl(PerKey, Type) -> - make_wl(PerKey, Type, [], 0). - -make_wl([{Key,L} | PerKey], Type, WL, Ins) -> - [Cs | I] = wl(L, Type), - make_wl(PerKey, Type, [{Key,Cs} | WL], Ins+I); -make_wl([], _Type, WL, Ins) -> - {WL, Ins}. - -wl(L, Type) -> - wl(L, Type, keep, skip, 0, []). - -wl([{_Seq, delete_key} | Cs], Type, _Del, Lookup, _I, _Objs) -> - wl(Cs, Type, delete, Lookup, 0, []); -wl([{_Seq, {delete_object, Object}} | Cs], Type, Del, Lookup, I, Objs) -> - NObjs = lists:keydelete(Object, 1, Objs), - wl(Cs, Type, Del, Lookup, I, [{Object,0} | NObjs]); -wl([{_Seq, {insert, Object}} | Cs], Type, _Del, Lookup, _I, _Objs) - when Type =:= set -> - wl(Cs, Type, delete, Lookup, 1, [{Object,-1}]); -wl([{_Seq, {insert, Object}} | Cs], Type, Del, Lookup, _I, Objs) -> - NObjs = - case lists:keyfind(Object, 1, Objs) of - {_, 0} -> - lists:keyreplace(Object, 1, Objs, {Object,-1}); - {_, _C} when Type =:= bag -> % C =:= 1; C =:= -1 - Objs; - {_, C} when C < 0 -> % when Type =:= duplicate_bag - lists:keyreplace(Object, 1, Objs, {Object,C-1}); - {_, C} -> % when C > 0, Type =:= duplicate_bag - lists:keyreplace(Object, 1, Objs, {Object,C+1}); - false when Del =:= delete -> - [{Object, -1} | Objs]; - false -> - [{Object, 1} | Objs] - end, - wl(Cs, Type, Del, Lookup, 1, NObjs); -wl([{_Seq, {lookup,_Pid}=Lookup} | Cs], Type, Del, _Lookup, I, Objs) -> - wl(Cs, Type, Del, Lookup, I, Objs); -wl([], _Type, Del, Lookup, I, Objs) -> - [{Del, Lookup, Objs} | I]. - -%% -> {NewHead, ok} | {NewHead, Error} -may_grow(Head, 0, once) -> - {Head, ok}; -may_grow(Head, _N, _How) when Head#head.fixed =/= false -> - {Head, ok}; -may_grow(#head{access = read}=Head, _N, _How) -> - {Head, ok}; -may_grow(Head, _N, _How) when Head#head.next >= ?MAXOBJS -> - {Head, ok}; -may_grow(Head, N, How) -> - Extra = erlang:min(2*?SEGSZ, Head#head.no_objects + N - Head#head.next), - case catch may_grow1(Head, Extra, How) of - {error, Reason} -> % alloc may throw error - {Head, {error, Reason}}; - Reply -> - Reply - end. - -may_grow1(Head, Extra, many_times) when Extra > ?SEGSZ -> - Reply = grow(Head, 1, undefined), - self() ! ?DETS_CALL(self(), may_grow), - Reply; -may_grow1(Head, Extra, _How) -> - grow(Head, Extra, undefined). - -%% -> {Head, ok} | throw({Head, Error}) -grow(Head, Extra, _SegZero) when Extra =< 0 -> - {Head, ok}; -grow(Head, Extra, undefined) -> - grow(Head, Extra, seg_zero()); -grow(Head, Extra, SegZero) -> - #head{n = N, next = Next, m = M} = Head, - SegNum = ?SLOT2SEG(Next), - {Head0, Ws1} = allocate_segment(Head, SegZero, SegNum), - {Head1, ok} = dets_utils:pwrite(Head0, Ws1), - %% If re_hash fails, segp_cache has been called, but it does not matter. - {ok, Ws2} = re_hash(Head1, N), - {Head2, ok} = dets_utils:pwrite(Head1, Ws2), - NewHead = - if - N + ?SEGSZ =:= M -> - Head2#head{n = 0, next = Next + ?SEGSZ, m = 2 * M, m2 = 4 * M}; - true -> - Head2#head{n = N + ?SEGSZ, next = Next + ?SEGSZ} - end, - grow(NewHead, Extra - ?SEGSZ, SegZero). - -seg_zero() -> - <<0:(4*?SEGSZ)/unit:8>>. - -find_object(Head, Object) -> - Key = element(Head#head.keypos, Object), - Slot = db_hash(Key, Head), - find_object(Head, Object, Slot). - -find_object(H, _Obj, Slot) when Slot >= H#head.next -> - false; -find_object(H, Obj, Slot) -> - {_Pos, Chain} = chain(H, Slot), - case catch find_obj(H, Obj, Chain) of - {ok, Pos} -> - {ok, Pos}; - _Else -> - false - end. - -find_obj(H, Obj, Pos) when Pos > 0 -> - {Next, _Sz, Term} = prterm(H, Pos, ?ReadAhead), - if - Term == Obj -> - {ok, Pos}; - true -> - find_obj(H, Obj, Next) - end. - -%% Given, a slot, return the {Pos, Chain} in the file where the -%% objects hashed to this slot reside. Pos is the position in the -%% file where the chain pointer is written and Chain is the position -%% in the file where the first object resides. -chain(Head, Slot) -> - Pos = ?SEGADDR(?SLOT2SEG(Slot)), - Segment = get_segp(Pos), - FinalPos = Segment + (4 * ?REM2(Slot, ?SEGSZ)), - {ok, <<Chain:32>>} = dets_utils:pread(Head, FinalPos, 4, 0), - {FinalPos, Chain}. - -%%% -%%% Cache routines depending on the dets file format. -%%% - -%% -> {Head, [LookedUpObject], pwrite_list()} | throw({Head, Error}) -eval_work_list(Head, WorkLists) -> - SWLs = tag_with_slot(WorkLists, Head, []), - P1 = dets_utils:family(SWLs), - {PerSlot, SlotPositions} = remove_slot_tag(P1, [], []), - {ok, Bins} = dets_utils:pread(SlotPositions, Head), - first_object(PerSlot, SlotPositions, Bins, Head, [], [], [], []). - -tag_with_slot([{K,_} = WL | WLs], Head, L) -> - tag_with_slot(WLs, Head, [{db_hash(K, Head), WL} | L]); -tag_with_slot([], _Head, L) -> - L. - -remove_slot_tag([{S,SWLs} | SSWLs], Ls, SPs) -> - remove_slot_tag(SSWLs, [SWLs | Ls], [slot_position(S) | SPs]); -remove_slot_tag([], Ls, SPs) -> - {Ls, SPs}. - -%% The initial chain pointers and the first object in each chain are -%% read "in parallel", that is, with one call to file:pread/2 (two -%% calls altogether). The following chain objects are read one by -%% one. This is a compromise: if the chains are long and threads are -%% active, it would be faster to keep a state for each chain and read -%% the objects of the chains in parallel, but the overhead would be -%% quite substantial. - -first_object([WorkLists | SPs], [{P1,_4} | Ss], [<<P2:32>> | Bs], Head, - ObjsToRead, ToRead, Ls, LU) when P2 =:= 0 -> - L0 = [{old,P1}], - {L, NLU} = eval_slot(Head, ?ReadAhead, P2, WorkLists, L0, LU), - first_object(SPs, Ss, Bs, Head, ObjsToRead, ToRead, [L | Ls], NLU); -first_object([WorkLists | SPs], [{P1,_4} | Ss], [<<P2:32>> | Bs], Head, - ObjsToRead, ToRead, Ls, LU) -> - E = {P1,P2,WorkLists}, - first_object(SPs, Ss, Bs, Head, - [E | ObjsToRead], [{P2, ?ReadAhead} | ToRead], Ls, LU); -first_object([], [], [], Head, ObjsToRead, ToRead, Ls, LU) -> - {ok, Bins} = dets_utils:pread(ToRead, Head), - case catch eval_first(Bins, ObjsToRead, Head, Ls, LU) of - {ok, NLs, NLU} -> - case create_writes(NLs, Head, [], 0) of - {Head1, [], 0} -> - {Head1, NLU, []}; - {Head1, Ws, No} -> - {NewHead, Ws2} = update_no_objects(Head1, Ws, No), - {NewHead, NLU, Ws2} - end; - _Error -> - throw(dets_utils:corrupt_reason(Head, bad_object)) - end. - -%% Update no_objects on the file too, if the number of segments that -%% dets:fsck/6 use for estimate has changed. -update_no_objects(Head, Ws, 0) -> {Head, Ws}; -update_no_objects(Head, Ws, Delta) -> - No = Head#head.no_objects, - NewNo = No + Delta, - NWs = - if - NewNo > ?MAXOBJS -> - Ws; - ?SLOT2SEG(No) =:= ?SLOT2SEG(NewNo) -> - Ws; - true -> - [{?NO_OBJECTS_POS, <<NewNo:32>>} | Ws] - end, - {Head#head{no_objects = NewNo}, NWs}. - -eval_first([<<Next:32, Sz:32, _Status:32, Bin/binary>> | Bins], - [SP | SPs], Head, Ls, LU) -> - {P1, P2, WLs} = SP, - L0 = [{old,P1}], - case byte_size(Bin) of - BinSz when BinSz >= Sz -> - Term = binary_to_term(Bin), - Key = element(Head#head.keypos, Term), - {L, NLU} = find_key(Head, P2, Next, Sz, Term, Key, WLs, L0, LU), - eval_first(Bins, SPs, Head, [L | Ls], NLU); - _BinSz -> - {L, NLU} = eval_slot(Head, Sz+?OHDSZ, P2, WLs, L0, LU), - eval_first(Bins, SPs, Head, [L | Ls], NLU) - end; -eval_first([], [], _Head, Ls, LU) -> - {ok, Ls, LU}. - -eval_slot(_Head, _TrySize, _Pos=0, [], L, LU) -> - {L, LU}; -eval_slot(Head, _TrySize, Pos=0, [WL | WLs], L, LU) -> - {_Key, {_Delete, LookUp, Objects}} = WL, - {NL, NLU} = end_of_key(Objects, LookUp, L, []), - eval_slot(Head, ?ReadAhead, Pos, WLs, NL, NLU++LU); -eval_slot(Head, TrySize, Pos, WLs, L, LU) -> - {NextPos, Size, Term} = prterm(Head, Pos, TrySize), - Key = element(Head#head.keypos, Term), - find_key(Head, Pos, NextPos, Size, Term, Key, WLs, L, LU). - -find_key(Head, Pos, NextPos, Size, Term, Key, WLs, L, LU) -> - case lists:keyfind(Key, 1, WLs) of - {_, {Delete, LookUp, Objects}} = WL -> - NWLs = lists:delete(WL, WLs), - {NewObjects, NL, LUK} = eval_object(Size, Term, Delete, LookUp, - Objects, Head, Pos, L, []), - eval_key(Key, Delete, LookUp, NewObjects, Head, NextPos, - NWLs, NL, LU, LUK); - false -> - L0 = [{old,Pos} | L], - eval_slot(Head, ?ReadAhead, NextPos, WLs, L0, LU) - end. - -eval_key(_Key, _Delete, Lookup, _Objects, Head, Pos, WLs, L, LU, LUK) - when Head#head.type =:= set -> - NLU = case Lookup of - {lookup, Pid} -> [{Pid,LUK} | LU]; - skip -> LU - end, - eval_slot(Head, ?ReadAhead, Pos, WLs, L, NLU); -eval_key(_Key, _Delete, LookUp, Objects, Head, Pos, WLs, L, LU, LUK) - when Pos =:= 0 -> - {NL, NLU} = end_of_key(Objects, LookUp, L, LUK), - eval_slot(Head, ?ReadAhead, Pos, WLs, NL, NLU++LU); -eval_key(Key, Delete, LookUp, Objects, Head, Pos, WLs, L, LU, LUK) -> - {NextPos, Size, Term} = prterm(Head, Pos, ?ReadAhead), - case element(Head#head.keypos, Term) of - Key -> - {NewObjects, NL, LUK1} = - eval_object(Size, Term, Delete, LookUp,Objects,Head,Pos,L,LUK), - eval_key(Key, Delete, LookUp, NewObjects, Head, NextPos, WLs, - NL, LU, LUK1); - Key2 -> - {L1, NLU} = end_of_key(Objects, LookUp, L, LUK), - find_key(Head, Pos, NextPos, Size, Term, Key2, WLs, L1, NLU++LU) - end. - -%% All objects in Objects have the key Key. -eval_object(Size, Term, Delete, LookUp, Objects, Head, Pos, L, LU) -> - Type = Head#head.type, - case lists:keyfind(Term, 1, Objects) of - {_Object, N} when N =:= 0 -> - L1 = [{delete,Pos,Size} | L], - {Objects, L1, LU}; - {_Object, N} when N < 0, Type =:= set -> - L1 = [{old,Pos} | L], - wl_lookup(LookUp, Objects, Term, L1, LU); - {Object, _N} when Type =:= bag -> % when N =:= 1; N =:= -1 - L1 = [{old,Pos} | L], - Objects1 = lists:keydelete(Object, 1, Objects), - wl_lookup(LookUp, Objects1, Term, L1, LU); - {Object, N} when N < 0, Type =:= duplicate_bag -> - L1 = [{old,Pos} | L], - Objects1 = lists:keyreplace(Object, 1, Objects, {Object,N+1}), - wl_lookup(LookUp, Objects1, Term, L1, LU); - {_Object, N} when N > 0, Type =:= duplicate_bag -> - L1 = [{old,Pos} | L], - wl_lookup(LookUp, Objects, Term, L1, LU); - false when Type =:= set, Delete =:= delete -> - case lists:keyfind(-1, 2, Objects) of - false -> % no inserted object, perhaps deleted objects - L1 = [{delete,Pos,Size} | L], - {[], L1, LU}; - {Term2, -1} -> - Bin2 = term_to_binary(Term2), - NSize = byte_size(Bin2), - Overwrite = - if - NSize =:= Size -> - true; - true -> - SizePos = sz2pos(Size+?OHDSZ), - NSizePos = sz2pos(NSize+?OHDSZ), - SizePos =:= NSizePos - end, - E = if - Overwrite -> - {overwrite,Bin2,Pos}; - true -> - {replace,Bin2,Pos,Size} - end, - wl_lookup(LookUp, [], Term2, [E | L], LU) - end; - false when Delete =:= delete -> - L1 = [{delete,Pos,Size} | L], - {Objects, L1, LU}; - false -> - L1 = [{old,Pos} | L], - wl_lookup(LookUp, Objects, Term, L1, LU) - end. - -%% Inlined. -wl_lookup({lookup,_}, Objects, Term, L, LU) -> - {Objects, L, [Term | LU]}; -wl_lookup(skip, Objects, _Term, L, LU) -> - {Objects, L, LU}. - -end_of_key([{Object,N0} | Objs], LookUp, L, LU) when N0 =/= 0 -> - N = abs(N0), - NL = [{insert,N,term_to_binary(Object)} | L], - NLU = case LookUp of - {lookup, _} -> - lists:duplicate(N, Object) ++ LU; - skip -> - LU - end, - end_of_key(Objs, LookUp, NL, NLU); -end_of_key([_ | Objects], LookUp, L, LU) -> - end_of_key(Objects, LookUp, L, LU); -end_of_key([], {lookup,Pid}, L, LU) -> - {L, [{Pid,LU}]}; -end_of_key([], skip, L, LU) -> - {L, LU}. - -create_writes([L | Ls], H, Ws, No) -> - {NH, NWs, NNo} = create_writes(L, H, Ws, No, 0, true), - create_writes(Ls, NH, NWs, NNo); -create_writes([], H, Ws, No) -> - {H, lists:reverse(Ws), No}. - -create_writes([{old,Pos} | L], H, Ws, No, _Next, true) -> - create_writes(L, H, Ws, No, Pos, true); -create_writes([{old,Pos} | L], H, Ws, No, Next, false) -> - W = {Pos, <<Next:32>>}, - create_writes(L, H, [W | Ws], No, Pos, true); -create_writes([{insert,N,Bin} | L], H, Ws, No, Next, _NextIsOld) -> - {NH, NWs, Pos} = create_inserts(N, H, Ws, Next, byte_size(Bin), Bin), - create_writes(L, NH, NWs, No+N, Pos, false); -create_writes([{overwrite,Bin,Pos} | L], H, Ws, No, Next, _) -> - Size = byte_size(Bin), - W = {Pos, [<<Next:32, Size:32, ?ACTIVE:32>>, Bin]}, - create_writes(L, H, [W | Ws], No, Pos, true); -create_writes([{replace,Bin,Pos,OSize} | L], H, Ws, No, Next, _) -> - Size = byte_size(Bin), - {H1, _} = dets_utils:free(H, Pos, OSize+?OHDSZ), - {NH, NewPos, _} = dets_utils:alloc(H1, ?OHDSZ + Size), - W1 = {NewPos, [<<Next:32, Size:32, ?ACTIVE:32>>, Bin]}, - NWs = if - Pos =:= NewPos -> - [W1 | Ws]; - true -> - W2 = {Pos+?STATUS_POS, <<?FREE:32>>}, - [W1,W2 | Ws] - end, - create_writes(L, NH, NWs, No, NewPos, false); -create_writes([{delete,Pos,Size} | L], H, Ws, No, Next, _) -> - {NH, _} = dets_utils:free(H, Pos, Size+?OHDSZ), - NWs = [{Pos+?STATUS_POS,<<?FREE:32>>} | Ws], - create_writes(L, NH, NWs, No-1, Next, false); -create_writes([], H, Ws, No, _Next, _NextIsOld) -> - {H, Ws, No}. - -create_inserts(0, H, Ws, Next, _Size, _Bin) -> - {H, Ws, Next}; -create_inserts(N, H, Ws, Next, Size, Bin) -> - {NH, Pos, _} = dets_utils:alloc(H, ?OHDSZ + Size), - W = {Pos, [<<Next:32, Size:32, ?ACTIVE:32>>, Bin]}, - create_inserts(N-1, NH, [W | Ws], Pos, Size, Bin). - -slot_position(S) -> - Pos = ?SEGADDR(?SLOT2SEG(S)), - Segment = get_segp(Pos), - FinalPos = Segment + (4 * ?REM2(S, ?SEGSZ)), - {FinalPos, 4}. - -%% Twice the size of a segment due to the bug in sz2pos/1. Inlined. -actual_seg_size() -> - ?POW(sz2pos(?SEGSZ*4)-1). - -segp_cache(Pos, Segment) -> - put(Pos, Segment). - -%% Inlined. -get_segp(Pos) -> - get(Pos). - -%% Bug: If Sz0 is equal to 2**k for some k, then 2**(k+1) bytes are -%% allocated (wasting 2**k bytes). -sz2pos(N) -> - 1 + dets_utils:log2(N+1). - -scan_objs(_Head, Bin, From, To, L, Ts, R, _Type) -> - scan_objs(Bin, From, To, L, Ts, R). - -scan_objs(Bin, From, To, L, Ts, -1) -> - {stop, Bin, From, To, L, Ts}; -scan_objs(B = <<_N:32, Sz:32, St:32, T/binary>>, From, To, L, Ts, R) -> - if - St =:= ?ACTIVE; - St =:= ?FREE -> % deleted after scanning started - case T of - <<BinTerm:Sz/binary, T2/binary>> -> - NTs = [BinTerm | Ts], - OSz = Sz + ?OHDSZ, - Skip = ?POW(sz2pos(OSz)-1) - OSz, - F2 = From + OSz, - NR = if - R < 0 -> - R + 1; - true -> - R + OSz + Skip - end, - scan_skip(T2, F2, To, Skip, L, NTs, NR); - _ -> - {more, From, To, L, Ts, R, Sz+?OHDSZ} - end; - true -> % a segment - scan_skip(B, From, To, actual_seg_size(), L, Ts, R) - end; -scan_objs(_B, From, To, L, Ts, R) -> - {more, From, To, L, Ts, R, 0}. - -scan_skip(Bin, From, To, Skip, L, Ts, R) when From + Skip < To -> - SkipPos = From + Skip, - case Bin of - <<_:Skip/binary, Tail/binary>> -> - scan_objs(Tail, SkipPos, To, L, Ts, R); - _ -> - {more, SkipPos, To, L, Ts, R, 0} - end; -scan_skip(Bin, From, To, Skip, L, Ts, R) when From + Skip =:= To -> - scan_next_allocated(Bin, From, To, L, Ts, R); -scan_skip(_Bin, From, _To, Skip, L, Ts, R) -> % when From + Skip > _To - From1 = From + Skip, - {more, From1, From1, L, Ts, R, 0}. - -scan_next_allocated(_Bin, _From, To, <<>>=L, Ts, R) -> - {more, To, To, L, Ts, R, 0}; -scan_next_allocated(Bin, From0, _To, <<From:32, To:32, L/binary>>, Ts, R) -> - Skip = From - From0, - scan_skip(Bin, From0, To, Skip, L, Ts, R). - -%% Read term from file at position Pos -prterm(Head, Pos, ReadAhead) -> - Res = dets_utils:pread(Head, Pos, ?OHDSZ, ReadAhead), - ?DEBUGF("file:pread(~tp, ~p, ?) -> ~p~n", [Head#head.filename, Pos, Res]), - {ok, <<Next:32, Sz:32, _Status:32, Bin0/binary>>} = Res, - ?DEBUGF("{Next, Sz} = ~p~n", [{Next, Sz}]), - Bin = case byte_size(Bin0) of - Actual when Actual >= Sz -> - Bin0; - _ -> - {ok, Bin1} = dets_utils:pread(Head, Pos + ?OHDSZ, Sz, 0), - Bin1 - end, - Term = binary_to_term(Bin), - {Next, Sz, Term}. - -%%%%%%%%%%%%%%%%% DEBUG functions %%%%%%%%%%%%%%%% - -file_info(FH) -> - #fileheader{closed_properly = CP, keypos = Kp, - m = M, next = Next, n = N, version = Version, - type = Type, no_objects = NoObjects} - = FH, - if - CP =:= 0 -> - {error, not_closed}; - FH#fileheader.cookie =/= ?MAGIC -> - {error, not_a_dets_file}; - FH#fileheader.version =/= ?FILE_FORMAT_VERSION -> - {error, bad_version}; - true -> - {ok, [{closed_properly,CP},{keypos,Kp},{m, M}, - {n,N},{next,Next},{no_objects,NoObjects}, - {type,Type},{version,Version}]} - end. - -v_segments(H) -> - v_segments(H, 0). - -v_segments(_H, ?SEGARRSZ) -> - done; -v_segments(H, SegNo) -> - Seg = dets_utils:read_4(H#head.fptr, ?SEGADDR(SegNo)), - if - Seg =:= 0 -> - done; - true -> - io:format("SEGMENT ~w ", [SegNo]), - io:format("At position ~w~n", [Seg]), - v_segment(H, SegNo, Seg, 0), - v_segments(H, SegNo+1) - end. - -v_segment(_H, _, _SegPos, ?SEGSZ) -> - done; -v_segment(H, SegNo, SegPos, SegSlot) -> - Slot = SegSlot + (SegNo * ?SEGSZ), - Chain = dets_utils:read_4(H#head.fptr, SegPos + (4 * SegSlot)), - if - Chain =:= 0 -> %% don't print empty chains - true; - true -> - io:format(" <~p>~p: [",[SegPos + (4 * SegSlot), Slot]), - print_chain(H, Chain) - end, - v_segment(H, SegNo, SegPos, SegSlot+1). - -print_chain(_H, 0) -> - io:format("] \n", []); -print_chain(H, Pos) -> - {ok, _} = file:position(H#head.fptr, Pos), - case rterm(H#head.fptr) of - {ok, 0, _Sz, Term} -> - io:format("<~p>~p] \n",[Pos, Term]); - {ok, Next, _Sz, Term} -> - io:format("<~p>~p, ", [Pos, Term]), - print_chain(H, Next); - Other -> - io:format("~nERROR ~p~n", [Other]) - end. - -%% Can't be used at the bucket level!!!! -%% Only when we go down a chain -rterm(F) -> - case catch rterm2(F) of - {'EXIT', Reason} -> %% truncated DAT file - dets_utils:vformat("** dets: Corrupt or truncated dets file~n", - []), - {error, Reason}; - Other -> - Other - end. - -rterm2(F) -> - {ok, <<Next:32, Sz:32, _:32>>} = file:read(F, ?OHDSZ), - {ok, Bin} = file:read(F, Sz), - Term = binary_to_term(Bin), - {ok, Next, Sz, Term}. - - diff --git a/lib/stdlib/src/dets_v9.erl b/lib/stdlib/src/dets_v9.erl index 361780c776..3ab8f87ebf 100644 --- a/lib/stdlib/src/dets_v9.erl +++ b/lib/stdlib/src/dets_v9.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2001-2013. All Rights Reserved. +%% Copyright Ericsson AB 2001-2016. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -24,8 +24,8 @@ -export([mark_dirty/1, read_file_header/2, check_file_header/2, do_perform_save/1, initiate_file/11, - prep_table_copy/9, init_freelist/2, fsck_input/4, - bulk_input/3, output_objs/4, bchunk_init/2, + prep_table_copy/9, init_freelist/1, fsck_input/4, + bulk_input/3, output_objs/3, bchunk_init/2, try_bchunk_header/2, compact_init/3, read_bchunks/2, write_cache/1, may_grow/3, find_object/2, slot_objs/2, scan_objs/8, db_hash/2, no_slots/1, table_parameters/1]). @@ -34,6 +34,8 @@ -export([cache_segps/3]). +-dialyzer(no_improper_lists). + -compile({inline, [{max_objsize,1},{maxobjsize,1}]}). -compile({inline, [{write_segment_file,6}]}). -compile({inline, [{sz2pos,1},{adjsz,1}]}). @@ -226,8 +228,8 @@ -define(CLOSED_PROPERLY_POS, 8). -define(D_POS, 20). -%%% Dets file versions up to 8 are handled in dets_v8. This module -%%% handles version 9, introduced in R8. +%%% This module handles Dets file format version 9, introduced in +%%% Erlang/OTP R8. %%% %%% Version 9(a) tables have 256 reserved bytes in the file header, %%% all initialized to zero. @@ -247,32 +249,32 @@ -define(OHDSZ, 8). % The size of the object header, in bytes. -define(STATUS_POS, 4). % Position of the status field. --define(OHDSZ_v8, 12). % The size of the version 8 object header. - %% The size of each object is a multiple of 16. %% BUMP is used when repairing files. -define(BUMP, 16). -%%% '$hash' is the value of HASH_PARMS in R8, '$hash2' is the value in R9. +%%% '$hash' is the value of HASH_PARMS in Erlang/OTP R8, '$hash2' is +%%% the value in Erlang/OTP R9. %%% %%% The fields of the ?HASH_PARMS records are the same, but having -%%% different tags makes bchunk_init on R8 nodes reject data from R9 -%%% nodes, and vice versa. This is overkill, and due to an oversight. -%%% What should have been done in R8 was to check the hash method, not -%%% only the type of the table and the key position. R8 nodes cannot -%%% handle the phash2 method. +%%% different tags makes bchunk_init on Erlang/OTP R8 nodes reject +%%% data from Erlang/OTP R9 nodes, and vice versa. This is overkill, +%%% and due to an oversight. What should have been done in Erlang/OTP +%%% R8 was to check the hash method, not only the type of the table +%%% and the key position. Erlang/OTP R8 nodes cannot handle the phash2 +%%% method. -define(HASH_PARMS, '$hash2'). -define(BCHUNK_FORMAT_VERSION, 1). -record(?HASH_PARMS, { - file_format_version, + file_format_version, bchunk_format_version, file, type, keypos, hash_method, n,m,next, min,max, no_objects,no_keys, - no_colls % [{LogSz,NoColls}], NoColls >= 0 + no_colls :: no_colls() }). -define(ACTUAL_SEG_SIZE, (?SEGSZ*4)). @@ -362,10 +364,8 @@ init_file(Fd, Tab, Fname, Type, Kp, MinSlots, MaxSlots, Ram, CacheSz, filename = Fname, name = Tab, cache = dets_utils:new_cache(CacheSz), - version = ?FILE_FORMAT_VERSION, bump = ?BUMP, - base = ?BASE, % to be overwritten - mod = ?MODULE + base = ?BASE % to be overwritten }, FreeListsPointer = 0, @@ -455,7 +455,7 @@ alloc_seg(Head, SegZero, SegNo, Part) -> {NewHead, InitSegment, [SegPointer]}. %% Read free lists (using a Buddy System) from file. -init_freelist(Head, true) -> +init_freelist(Head) -> Pos = Head#head.freelists_p, free_lists_from_file(Head, Pos). @@ -508,12 +508,10 @@ read_file_header(Fd, FileName) -> md5 = erlang:md5(MD5DigestedPart), trailer = FileSize + FlBase, eof = EOF, - n = N, - mod = ?MODULE}, + n = N}, {ok, Fd, FH}. -%% -> {ok, head(), ExtraInfo} | {error, Reason} (Reason lacking file name) -%% ExtraInfo = true +%% -> {ok, head()} | {error, Reason} (Reason lacking file name) check_file_header(FH, Fd) -> HashBif = code_to_hash_method(FH#fileheader.hash_method), Test = @@ -532,14 +530,14 @@ check_file_header(FH, Fd) -> HashBif =:= undefined -> {error, bad_hash_bif}; FH#fileheader.closed_properly =:= ?CLOSED_PROPERLY -> - {ok, true}; + ok; FH#fileheader.closed_properly =:= ?NOT_PROPERLY_CLOSED -> {error, not_closed}; true -> {error, not_a_dets_file} end, case Test of - {ok, ExtraInfo} -> + ok -> MaxObjSize = max_objsize(FH#fileheader.no_colls), H = #head{ m = FH#fileheader.m, @@ -561,11 +559,9 @@ check_file_header(FH, Fd) -> min_no_slots = FH#fileheader.min_no_slots, max_no_slots = FH#fileheader.max_no_slots, no_collections = FH#fileheader.no_colls, - version = ?FILE_FORMAT_VERSION, - mod = ?MODULE, bump = ?BUMP, base = FH#fileheader.fl_base}, - {ok, H, ExtraInfo}; + {ok, H}; Error -> Error end. @@ -619,7 +615,7 @@ no_segs(NoSlots) -> %%% %%% bulk_input/3. Initialization, the general case (any stream of objects). -%%% output_objs/4. Initialization (general case) and repair. +%%% output_objs/3. Initialization (general case) and repair. %%% bchunk_init/2. Initialization using bchunk. bulk_input(Head, InitFun, _Cntrs) -> @@ -676,7 +672,7 @@ bulk_objects([], _Head, Kp, Seq, L) when is_integer(Kp), is_integer(Seq) -> -define(OBJ_COUNTER, 2). -define(KEY_COUNTER, 3). -output_objs(OldV, Head, SlotNums, Cntrs) when OldV =< 9 -> +output_objs(Head, SlotNums, Cntrs) -> fun(close) -> %% Make sure that the segments are initialized in case %% init_table has been called. @@ -684,31 +680,31 @@ output_objs(OldV, Head, SlotNums, Cntrs) when OldV =< 9 -> Acc = [], % This is the only way Acc can be empty. true = ets:insert(Cntrs, {?FSCK_SEGMENT,0,[],0}), true = ets:insert(Cntrs, {?COUNTERS, 0, 0}), - Fun = output_objs2(foo, Acc, OldV, Head, Cache, Cntrs, + Fun = output_objs2(foo, Acc, Head, Cache, Cntrs, SlotNums, bar), Fun(close); ([]) -> - output_objs(OldV, Head, SlotNums, Cntrs); + output_objs(Head, SlotNums, Cntrs); (L) -> %% Information about number of objects per size is not %% relevant for version 9. It is the number of collections %% that matters. true = ets:delete_all_objects(Cntrs), true = ets:insert(Cntrs, {?COUNTERS, 0, 0}), - Es = bin2term(L, OldV, Head#head.keypos), + Es = bin2term(L, Head#head.keypos), %% The cache is a tuple indexed by the (log) size. An element %% is [BinaryObject]. Cache = ?VEMPTY, {NE, NAcc, NCache} = output_slots(Es, Head, Cache, Cntrs, 0, 0), - output_objs2(NE, NAcc, OldV, Head, NCache, Cntrs, SlotNums, 1) + output_objs2(NE, NAcc, Head, NCache, Cntrs, SlotNums, 1) end. -output_objs2(E, Acc, OldV, Head, Cache, SizeT, SlotNums, 0) -> +output_objs2(E, Acc, Head, Cache, SizeT, SlotNums, 0) -> NCache = write_all_sizes(Cache, SizeT, Head, more), %% Number of handled file_sorter chunks before writing: Max = erlang:max(1, erlang:min(tuple_size(NCache), 10)), - output_objs2(E, Acc, OldV, Head, NCache, SizeT, SlotNums, Max); -output_objs2(E, Acc, OldV, Head, Cache, SizeT, SlotNums, ChunkI) -> + output_objs2(E, Acc, Head, NCache, SizeT, SlotNums, Max); +output_objs2(E, Acc, Head, Cache, SizeT, SlotNums, ChunkI) -> fun(close) -> {_, [], Cache1} = if @@ -745,11 +741,10 @@ output_objs2(E, Acc, OldV, Head, Cache, SizeT, SlotNums, ChunkI) -> end end; (L) -> - Es = bin2term(L, OldV, Head#head.keypos), + Es = bin2term(L, Head#head.keypos), {NE, NAcc, NCache} = output_slots(E, Es, Acc, Head, Cache, SizeT, 0, 0), - output_objs2(NE, NAcc, OldV, Head, NCache, SizeT, SlotNums, - ChunkI-1) + output_objs2(NE, NAcc, Head, NCache, SizeT, SlotNums, ChunkI-1) end. %%% Compaction. @@ -1243,10 +1238,8 @@ allocate_all(Head, [{LSize,_,Data,NoCollections} | DTL], L) -> E = {LSize,Addr,Data,NoCollections}, allocate_all(NewHead, DTL, [E | L]). -bin2term(Bin, 9, Kp) -> - bin2term1(Bin, Kp, []); -bin2term(Bin, 8, Kp) -> - bin2term_v8(Bin, Kp, []). +bin2term(Bin, Kp) -> + bin2term1(Bin, Kp, []). bin2term1([<<Slot:32, Seq:32, BinTerm/binary>> | BTs], Kp, L) -> Term = binary_to_term(BinTerm), @@ -1255,13 +1248,6 @@ bin2term1([<<Slot:32, Seq:32, BinTerm/binary>> | BTs], Kp, L) -> bin2term1([], _Kp, L) -> lists:reverse(L). -bin2term_v8([<<Slot:32, BinTerm/binary>> | BTs], Kp, L) -> - Term = binary_to_term(BinTerm), - Key = element(Kp, Term), - bin2term_v8(BTs, Kp, [{Slot, Key, foo, Term, BinTerm} | L]); -bin2term_v8([], _Kp, L) -> - lists:reverse(L). - write_all_sizes({}=Cache, _SizeT, _Head, _More) -> Cache; write_all_sizes(Cache, SizeT, Head, More) -> @@ -1459,7 +1445,7 @@ temp_file(Head, SizeT, N) -> %% Does not close Fd. fsck_input(Head, Fd, Cntrs, FileHeader) -> MaxSz0 = case FileHeader#fileheader.has_md5 of - true when is_integer(FileHeader#fileheader.no_colls) -> + true when is_list(FileHeader#fileheader.no_colls) -> ?POW(max_objsize(FileHeader#fileheader.no_colls)); _ -> %% The file is not compressed, so the bucket size @@ -1483,10 +1469,10 @@ fsck_input(Head, State, Fd, MaxSz, Cntrs) -> done -> end_of_input; {done, L, _Seq} -> - R = count_input(Head, Cntrs, L), + R = count_input(L), {R, fsck_input(Head, done, Fd, MaxSz, Cntrs)}; {cont, L, Bin, Pos, Seq} -> - R = count_input(Head, Cntrs, L), + R = count_input(L), FR = fsck_objs(Bin, Head#head.keypos, Head, [], Seq), NewState = fsck_read(FR, Pos, Fd, MaxSz, Head), {R, fsck_input(Head, NewState, Fd, MaxSz, Cntrs)} @@ -1494,20 +1480,9 @@ fsck_input(Head, State, Fd, MaxSz, Cntrs) -> end. %% The ets table Cntrs is used for counting objects per size. -count_input(Head, Cntrs, L) when Head#head.version =:= 8 -> - count_input1(Cntrs, L, []); -count_input(_Head, _Cntrs, L) -> +count_input(L) -> lists:reverse(L). -count_input1(Cntrs, [[LogSz | B] | Ts], L) -> - case catch ets:update_counter(Cntrs, LogSz, 1) of - N when is_integer(N) -> ok; - _Badarg -> true = ets:insert(Cntrs, {LogSz, 1}) - end, - count_input1(Cntrs, Ts, [B | L]); -count_input1(_Cntrs, [], L) -> - L. - fsck_read(Pos, F, L, Seq) -> case file:position(F, Pos) of {ok, _} -> @@ -1562,11 +1537,6 @@ fsck_objs(Bin = <<Sz:32, Status:32, Tail/binary>>, Kp, Head, L, Seq) -> fsck_objs(Bin, _Kp, _Head, L, Seq) -> {more, Bin, 0, L, Seq}. -make_objects([{K,BT}|Os], Seq, Kp, Head, L) when Head#head.version =:= 8 -> - LogSz = dets_v8:sz2pos(byte_size(BT)+?OHDSZ_v8), - Slot = dets_v8:db_hash(K, Head), - Obj = [LogSz | <<Slot:32, LogSz:8, BT/binary>>], - make_objects(Os, Seq, Kp, Head, [Obj | L]); make_objects([{K,BT} | Os], Seq, Kp, Head, L) -> Obj = make_object(Head, K, Seq, BT), make_objects(Os, Seq+1, Kp, Head, [Obj | L]); @@ -1605,7 +1575,7 @@ do_perform_save(H) -> FileHeader = file_header(H1, FreeListsPointer, ?CLOSED_PROPERLY), case dets_utils:debug_mode() of true -> - TmpHead0 = init_freelist(H1#head{fixed = false}, true), + TmpHead0 = init_freelist(H1#head{fixed = false}), TmpHead = TmpHead0#head{base = H1#head.base}, case catch dets_utils:all_allocated_as_list(TmpHead) @@ -1792,7 +1762,7 @@ table_parameters(Head) -> (E, A) -> [E | A] end, [], CL), NoColls = lists:reverse(NoColls0), - #?HASH_PARMS{file_format_version = Head#head.version, + #?HASH_PARMS{file_format_version = ?FILE_FORMAT_VERSION, bchunk_format_version = ?BCHUNK_FORMAT_VERSION, file = filename:basename(Head#head.filename), type = Head#head.type, diff --git a/lib/stdlib/src/dict.erl b/lib/stdlib/src/dict.erl index 6ce3710f87..9449ba3dc2 100644 --- a/lib/stdlib/src/dict.erl +++ b/lib/stdlib/src/dict.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2000-2014. All Rights Reserved. +%% Copyright Ericsson AB 2000-2016. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -38,7 +38,7 @@ %% Standard interface. -export([new/0,is_key/2,to_list/1,from_list/1,size/1,is_empty/1]). --export([fetch/2,find/2,fetch_keys/1,erase/2]). +-export([fetch/2,find/2,fetch_keys/1,erase/2,take/2]). -export([store/3,append/3,append_list/3,update/3,update/4,update_counter/3]). -export([fold/3,map/2,filter/2,merge/3]). @@ -172,6 +172,27 @@ erase_key(Key, [E|Bkt0]) -> {[E|Bkt1],Dc}; erase_key(_, []) -> {[],0}. +-spec take(Key, Dict) -> {Value, Dict1} | error when + Dict :: dict(Key, Value), + Dict1 :: dict(Key, Value), + Key :: term(), + Value :: term(). + +take(Key, D0) -> + Slot = get_slot(D0, Key), + case on_bucket(fun (B0) -> take_key(Key, B0) end, D0, Slot) of + {D1,{Value,Dc}} -> + {Value, maybe_contract(D1, Dc)}; + {_,error} -> error + end. + +take_key(Key, [?kv(Key,Val)|Bkt]) -> + {Bkt,{Val,1}}; +take_key(Key, [E|Bkt0]) -> + {Bkt1,Res} = take_key(Key, Bkt0), + {[E|Bkt1],Res}; +take_key(_, []) -> {[],error}. + -spec store(Key, Value, Dict1) -> Dict2 when Dict1 :: dict(Key, Value), Dict2 :: dict(Key, Value). @@ -333,6 +354,8 @@ update_counter(Key, Incr, D0) when is_number(Incr) -> D0, Slot), maybe_expand(D1, Ic). +-dialyzer({no_improper_lists, counter_bkt/3}). + counter_bkt(Key, I, [?kv(Key,Val)|Bkt]) -> {[?kv(Key,Val+I)|Bkt],0}; counter_bkt(Key, I, [Other|Bkt0]) -> diff --git a/lib/stdlib/src/digraph.erl b/lib/stdlib/src/digraph.erl index e51e560542..8a4df95027 100644 --- a/lib/stdlib/src/digraph.erl +++ b/lib/stdlib/src/digraph.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2014. All Rights Reserved. +%% Copyright Ericsson AB 1996-2016. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -338,6 +338,8 @@ edge(G, E) -> %% -spec new_edge_id(graph()) -> edge(). +-dialyzer({no_improper_lists, new_edge_id/1}). + new_edge_id(G) -> NT = G#digraph.ntab, [{'$eid', K}] = ets:lookup(NT, '$eid'), @@ -350,6 +352,8 @@ new_edge_id(G) -> %% -spec new_vertex_id(graph()) -> vertex(). +-dialyzer({no_improper_lists, new_vertex_id/1}). + new_vertex_id(G) -> NT = G#digraph.ntab, [{'$vid', K}] = ets:lookup(NT, '$vid'), diff --git a/lib/stdlib/src/digraph_utils.erl b/lib/stdlib/src/digraph_utils.erl index ef4c2e94fe..4aa9ae810d 100644 --- a/lib/stdlib/src/digraph_utils.erl +++ b/lib/stdlib/src/digraph_utils.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1999-2014. All Rights Reserved. +%% Copyright Ericsson AB 1999-2016. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. diff --git a/lib/stdlib/src/edlin.erl b/lib/stdlib/src/edlin.erl index 8c7a984f1c..5df9c504f9 100644 --- a/lib/stdlib/src/edlin.erl +++ b/lib/stdlib/src/edlin.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2013. All Rights Reserved. +%% Copyright Ericsson AB 1996-2016. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -83,7 +83,7 @@ edit_line(Cs, {line,P,L,M}) -> edit_line1(Cs, {line,P,L,{blink,N}}) -> edit(Cs, P, L, none, [{move_rel,N}]); edit_line1(Cs, {line,P,{[],[]},none}) -> - {more_chars, {line,P,{lists:reverse(Cs),[]},none},[{put_chars, unicode, Cs}]}; + {more_chars, {line,P,{string:reverse(Cs),[]},none},[{put_chars, unicode, Cs}]}; edit_line1(Cs, {line,P,L,M}) -> edit(Cs, P, L, M, []). @@ -93,14 +93,14 @@ edit([C|Cs], P, {Bef,Aft}, Prefix, Rs0) -> case key_map(C, Prefix) of meta -> edit(Cs, P, {Bef,Aft}, meta, Rs0); - meta_o -> - edit(Cs, P, {Bef,Aft}, meta_o, Rs0); - meta_csi -> - edit(Cs, P, {Bef,Aft}, meta_csi, Rs0); - meta_meta -> - edit(Cs, P, {Bef,Aft}, meta_meta, Rs0); - {csi, _} = Csi -> - edit(Cs, P, {Bef,Aft}, Csi, Rs0); + meta_o -> + edit(Cs, P, {Bef,Aft}, meta_o, Rs0); + meta_csi -> + edit(Cs, P, {Bef,Aft}, meta_csi, Rs0); + meta_meta -> + edit(Cs, P, {Bef,Aft}, meta_meta, Rs0); + {csi, _} = Csi -> + edit(Cs, P, {Bef,Aft}, Csi, Rs0); meta_left_sq_bracket -> edit(Cs, P, {Bef,Aft}, meta_left_sq_bracket, Rs0); search_meta -> @@ -110,8 +110,8 @@ edit([C|Cs], P, {Bef,Aft}, Prefix, Rs0) -> ctlx -> edit(Cs, P, {Bef,Aft}, ctlx, Rs0); new_line -> - {done, reverse(Bef, Aft ++ "\n"), Cs, - reverse(Rs0, [{move_rel,length(Aft)},{put_chars,unicode,"\n"}])}; + {done, get_line(Bef, Aft ++ "\n"), Cs, + reverse(Rs0, [{move_rel,cp_len(Aft)},{put_chars,unicode,"\n"}])}; redraw_line -> Rs1 = erase(P, Bef, Aft, Rs0), Rs = redraw(P, Bef, Aft, Rs1), @@ -157,7 +157,7 @@ edit([], P, L, {blink,N}, Rs) -> edit([], P, L, Prefix, Rs) -> {more_chars,{line,P,L,Prefix},reverse(Rs)}; edit(eof, _, {Bef,Aft}, _, Rs) -> - {done,reverse(Bef, Aft),[],reverse(Rs, [{move_rel,length(Aft)}])}. + {done,get_line(Bef, Aft),[],reverse(Rs, [{move_rel,cp_len(Aft)}])}. %% %% Assumes that arg is a string %% %% Horizontal whitespace only. @@ -227,6 +227,8 @@ key_map($F, meta_o) -> end_of_line; key_map($\177, none) -> backward_delete_char; key_map($\177, meta) -> backward_kill_word; key_map($[, meta) -> meta_left_sq_bracket; +key_map($H, meta_left_sq_bracket) -> beginning_of_line; +key_map($F, meta_left_sq_bracket) -> end_of_line; key_map($D, meta_left_sq_bracket) -> backward_char; key_map($C, meta_left_sq_bracket) -> forward_char; % support a few <CTRL>+<CURSOR LEFT|RIGHT> combinations... @@ -237,8 +239,10 @@ key_map($[, meta_meta) -> meta_csi; key_map($C, meta_csi) -> forward_word; key_map($D, meta_csi) -> backward_word; key_map($1, meta_left_sq_bracket) -> {csi, "1"}; +key_map($3, meta_left_sq_bracket) -> {csi, "3"}; key_map($5, meta_left_sq_bracket) -> {csi, "5"}; key_map($5, {csi, "1;"}) -> {csi, "1;5"}; +key_map($~, {csi, "3"}) -> forward_delete_char; key_map($C, {csi, "5"}) -> forward_word; key_map($C, {csi, "1;5"}) -> forward_word; key_map($D, {csi, "5"}) -> backward_word; @@ -275,11 +279,21 @@ key_map(C, search) -> {insert_search,C}; key_map(C, _) -> {undefined,C}. %% do_op(Action, Before, After, Requests) - -do_op({insert,C}, Bef, [], Rs) -> - {{[C|Bef],[]},[{put_chars, unicode,[C]}|Rs]}; -do_op({insert,C}, Bef, Aft, Rs) -> - {{[C|Bef],Aft},[{insert_chars, unicode, [C]}|Rs]}; +%% Before and After are of lists of type string:grapheme_cluster() +do_op({insert,C}, [], [], Rs) -> + {{[C],[]},[{put_chars, unicode,[C]}|Rs]}; +do_op({insert,C}, [Bef|Bef0], [], Rs) -> + case string:to_graphemes([Bef,C]) of + [GC] -> {{[GC|Bef0],[]},[{put_chars, unicode,[C]}|Rs]}; + _ -> {{[C,Bef|Bef0],[]},[{put_chars, unicode,[C]}|Rs]} + end; +do_op({insert,C}, [], Aft, Rs) -> + {{[C],Aft},[{insert_chars, unicode,[C]}|Rs]}; +do_op({insert,C}, [Bef|Bef0], Aft, Rs) -> + case string:to_graphemes([Bef,C]) of + [GC] -> {{[GC|Bef0],Aft},[{insert_chars, unicode,[C]}|Rs]}; + _ -> {{[C,Bef|Bef0],Aft},[{insert_chars, unicode,[C]}|Rs]} + end; %% Search mode prompt always looks like (search)`$TERMS': $RESULT. %% the {insert_search, _} handlings allow to share this implementation %% correctly with group.erl. This module provides $TERMS, and group.erl @@ -295,13 +309,13 @@ do_op({insert_search, C}, Bef, [], Rs) -> [{insert_chars, unicode, [C]++Aft}, {delete_chars,-3} | Rs], search}; do_op({insert_search, C}, Bef, Aft, Rs) -> - Offset= length(Aft), + Offset= cp_len(Aft), NAft = "': ", {{[C|Bef],NAft}, [{insert_chars, unicode, [C]++NAft}, {delete_chars,-Offset} | Rs], search}; do_op({search, backward_delete_char}, [_|Bef], Aft, Rs) -> - Offset= length(Aft)+1, + Offset= cp_len(Aft)+1, NAft = "': ", {{Bef,NAft}, [{insert_chars, unicode, NAft}, {delete_chars,-Offset}|Rs], @@ -310,13 +324,13 @@ do_op({search, backward_delete_char}, [], _Aft, Rs) -> Aft="': ", {{[],Aft}, Rs, search}; do_op({search, skip_up}, Bef, Aft, Rs) -> - Offset= length(Aft), + Offset= cp_len(Aft), NAft = "': ", {{[$\^R|Bef],NAft}, % we insert ^R as a flag to whoever called us [{insert_chars, unicode, NAft}, {delete_chars,-Offset}|Rs], search}; do_op({search, skip_down}, Bef, Aft, Rs) -> - Offset= length(Aft), + Offset= cp_len(Aft), NAft = "': ", {{[$\^S|Bef],NAft}, % we insert ^S as a flag to whoever called us [{insert_chars, unicode, NAft}, {delete_chars,-Offset}|Rs], @@ -324,12 +338,12 @@ do_op({search, skip_down}, Bef, Aft, Rs) -> do_op({search, search_found}, _Bef, Aft, Rs) -> "': "++NAft = Aft, {{[],NAft}, - [{put_chars, unicode, "\n"}, {move_rel,-length(Aft)} | Rs], + [{put_chars, unicode, "\n"}, {move_rel,-cp_len(Aft)} | Rs], search_found}; do_op({search, search_quit}, _Bef, Aft, Rs) -> "': "++NAft = Aft, {{[],NAft}, - [{put_chars, unicode, "\n"}, {move_rel,-length(Aft)} | Rs], + [{put_chars, unicode, "\n"}, {move_rel,-cp_len(Aft)} | Rs], search_quit}; %% do blink after $$ do_op({blink,C,M}, Bef=[$$,$$|_], Aft, Rs) -> @@ -357,14 +371,16 @@ do_op(auto_blink, Bef, Aft, Rs) -> N -> {blink,N+1,{Bef,Aft}, [{move_rel,-(N+1)}|Rs]} end; -do_op(forward_delete_char, Bef, [_|Aft], Rs) -> - {{Bef,Aft},[{delete_chars,1}|Rs]}; -do_op(backward_delete_char, [_|Bef], Aft, Rs) -> - {{Bef,Aft},[{delete_chars,-1}|Rs]}; +do_op(forward_delete_char, Bef, [GC|Aft], Rs) -> + {{Bef,Aft},[{delete_chars,gc_len(GC)}|Rs]}; +do_op(backward_delete_char, [GC|Bef], Aft, Rs) -> + {{Bef,Aft},[{delete_chars,-gc_len(GC)}|Rs]}; do_op(transpose_char, [C1,C2|Bef], [], Rs) -> - {{[C2,C1|Bef],[]},[{put_chars, unicode,[C1,C2]},{move_rel,-2}|Rs]}; + Len = gc_len(C1)+gc_len(C2), + {{[C2,C1|Bef],[]},[{put_chars, unicode,[C1,C2]},{move_rel,-Len}|Rs]}; do_op(transpose_char, [C2|Bef], [C1|Aft], Rs) -> - {{[C2,C1|Bef],Aft},[{put_chars, unicode,[C1,C2]},{move_rel,-1}|Rs]}; + Len = gc_len(C2), + {{[C2,C1|Bef],Aft},[{put_chars, unicode,[C1,C2]},{move_rel,-Len}|Rs]}; do_op(kill_word, Bef, Aft0, Rs) -> {Aft1,Kill0,N0} = over_non_word(Aft0, [], 0), {Aft,Kill,N} = over_word(Aft1, Kill0, N0), @@ -377,7 +393,7 @@ do_op(backward_kill_word, Bef0, Aft, Rs) -> {{Bef,Aft},[{delete_chars,-N}|Rs]}; do_op(kill_line, Bef, Aft, Rs) -> put(kill_buffer, Aft), - {{Bef,[]},[{delete_chars,length(Aft)}|Rs]}; + {{Bef,[]},[{delete_chars,cp_len(Aft)}|Rs]}; do_op(yank, Bef, [], Rs) -> Kill = get(kill_buffer), {{reverse(Kill, Bef),[]},[{put_chars, unicode,Kill}|Rs]}; @@ -385,9 +401,9 @@ do_op(yank, Bef, Aft, Rs) -> Kill = get(kill_buffer), {{reverse(Kill, Bef),Aft},[{insert_chars, unicode,Kill}|Rs]}; do_op(forward_char, Bef, [C|Aft], Rs) -> - {{[C|Bef],Aft},[{move_rel,1}|Rs]}; + {{[C|Bef],Aft},[{move_rel,gc_len(C)}|Rs]}; do_op(backward_char, [C|Bef], Aft, Rs) -> - {{Bef,[C|Aft]},[{move_rel,-1}|Rs]}; + {{Bef,[C|Aft]},[{move_rel,-gc_len(C)}|Rs]}; do_op(forward_word, Bef0, Aft0, Rs) -> {Aft1,Bef1,N0} = over_non_word(Aft0, Bef0, 0), {Aft,Bef,N} = over_word(Aft1, Bef1, N0), @@ -396,17 +412,17 @@ do_op(backward_word, Bef0, Aft0, Rs) -> {Bef1,Aft1,N0} = over_non_word(Bef0, Aft0, 0), {Bef,Aft,N} = over_word(Bef1, Aft1, N0), {{Bef,Aft},[{move_rel,-N}|Rs]}; -do_op(beginning_of_line, [C|Bef], Aft, Rs) -> - {{[],reverse(Bef, [C|Aft])},[{move_rel,-(length(Bef)+1)}|Rs]}; +do_op(beginning_of_line, [_|_]=Bef, Aft, Rs) -> + {{[],reverse(Bef, Aft)},[{move_rel,-(cp_len(Bef))}|Rs]}; do_op(beginning_of_line, [], Aft, Rs) -> {{[],Aft},Rs}; -do_op(end_of_line, Bef, [C|Aft], Rs) -> - {{reverse(Aft, [C|Bef]),[]},[{move_rel,length(Aft)+1}|Rs]}; +do_op(end_of_line, Bef, [_|_]=Aft, Rs) -> + {{reverse(Aft, Bef),[]},[{move_rel,cp_len(Aft)}|Rs]}; do_op(end_of_line, Bef, [], Rs) -> {{Bef,[]},Rs}; do_op(ctlu, Bef, Aft, Rs) -> put(kill_buffer, reverse(Bef)), - {{[], Aft}, [{delete_chars, -length(Bef)} | Rs]}; + {{[], Aft}, [{delete_chars, -cp_len(Bef)} | Rs]}; do_op(beep, Bef, Aft, Rs) -> {{Bef,Aft},[beep|Rs]}; do_op(_, Bef, Aft, Rs) -> @@ -432,7 +448,7 @@ over_word(Cs, Stack, N) -> until_quote([$\'|Cs], Stack, N) -> {Cs, [$\'|Stack], N+1}; until_quote([C|Cs], Stack, N) -> - until_quote(Cs, [C|Stack], N+1). + until_quote(Cs, [C|Stack], N+gc_len(C)). over_word1([$\'=C|Cs], Stack, N) -> until_quote(Cs, [C|Stack], N+1); @@ -441,7 +457,7 @@ over_word1(Cs, Stack, N) -> over_word2([C|Cs], Stack, N) -> case word_char(C) of - true -> over_word2(Cs, [C|Stack], N+1); + true -> over_word2(Cs, [C|Stack], N+gc_len(C)); false -> {[C|Cs],Stack,N} end; over_word2([], Stack, N) when is_integer(N) -> @@ -450,7 +466,7 @@ over_word2([], Stack, N) when is_integer(N) -> over_non_word([C|Cs], Stack, N) -> case word_char(C) of true -> {[C|Cs],Stack,N}; - false -> over_non_word(Cs, [C|Stack], N+1) + false -> over_non_word(Cs, [C|Stack], N+gc_len(C)) end; over_non_word([], Stack, N) -> {[],Stack,N}. @@ -461,7 +477,7 @@ word_char(C) when C >= $a, C =< $z -> true; word_char(C) when C >= $ß, C =< $ÿ, C =/= $÷ -> true; word_char(C) when C >= $0, C =< $9 -> true; word_char(C) when C =:= $_ -> true; -word_char(C) when C =:= $. -> true; % accept dot-separated names +word_char([_|_]) -> true; %% Is grapheme word_char(_) -> false. %% over_white(Chars, InitialStack, InitialCount) -> @@ -485,8 +501,8 @@ over_paren(Chars, Paren, Match) -> over_paren([C,$$,$$|Cs], Paren, Match, D, N, L) -> over_paren([C|Cs], Paren, Match, D, N+2, L); -over_paren([_,$$|Cs], Paren, Match, D, N, L) -> - over_paren(Cs, Paren, Match, D, N+2, L); +over_paren([GC,$$|Cs], Paren, Match, D, N, L) -> + over_paren(Cs, Paren, Match, D, N+1+gc_len(GC), L); over_paren([Match|_], _Paren, Match, 1, N, _) -> N; over_paren([Match|Cs], Paren, Match, D, N, [Match|L]) -> @@ -515,8 +531,8 @@ over_paren([$[|_], _, _, _, _, _) -> over_paren([${|_], _, _, _, _, _) -> beep; -over_paren([_|Cs], Paren, Match, D, N, L) -> - over_paren(Cs, Paren, Match, D, N+1, L); +over_paren([GC|Cs], Paren, Match, D, N, L) -> + over_paren(Cs, Paren, Match, D, N+gc_len(GC), L); over_paren([], _, _, _, _, _) -> 0. @@ -526,8 +542,8 @@ over_paren_auto(Chars) -> over_paren_auto([C,$$,$$|Cs], D, N, L) -> over_paren_auto([C|Cs], D, N+2, L); -over_paren_auto([_,$$|Cs], D, N, L) -> - over_paren_auto(Cs, D, N+2, L); +over_paren_auto([GC,$$|Cs], D, N, L) -> + over_paren_auto(Cs, D, N+1+gc_len(GC), L); over_paren_auto([$(|_], _, N, []) -> {N, $)}; @@ -550,8 +566,8 @@ over_paren_auto([$[|Cs], D, N, [$[|L]) -> over_paren_auto([${|Cs], D, N, [${|L]) -> over_paren_auto(Cs, D, N+1, L); -over_paren_auto([_|Cs], D, N, L) -> - over_paren_auto(Cs, D, N+1, L); +over_paren_auto([GC|Cs], D, N, L) -> + over_paren_auto(Cs, D, N+gc_len(GC), L); over_paren_auto([], _, _, _) -> 0. @@ -571,28 +587,43 @@ erase_inp({line,_,{Bef,Aft},_}) -> reverse(erase([], Bef, Aft, [])). erase(Pbs, Bef, Aft, Rs) -> - [{delete_chars,-length(Pbs)-length(Bef)},{delete_chars,length(Aft)}|Rs]. + [{delete_chars,-cp_len(Pbs)-cp_len(Bef)},{delete_chars,cp_len(Aft)}|Rs]. redraw_line({line,Pbs,{Bef,Aft},_}) -> reverse(redraw(Pbs, Bef, Aft, [])). redraw(Pbs, Bef, Aft, Rs) -> - [{move_rel,-length(Aft)},{put_chars, unicode,reverse(Bef, Aft)},{put_chars, unicode,Pbs}|Rs]. + [{move_rel,-cp_len(Aft)},{put_chars, unicode,reverse(Bef, Aft)},{put_chars, unicode,Pbs}|Rs]. length_before({line,Pbs,{Bef,_Aft},_}) -> - length(Pbs) + length(Bef). + cp_len(Pbs) + cp_len(Bef). length_after({line,_,{_Bef,Aft},_}) -> - length(Aft). + cp_len(Aft). prompt({line,Pbs,_,_}) -> Pbs. current_line({line,_,{Bef, Aft},_}) -> - reverse(Bef, Aft ++ "\n"). + get_line(Bef, Aft ++ "\n"). current_chars({line,_,{Bef,Aft},_}) -> - reverse(Bef, Aft). + get_line(Bef, Aft). + +get_line(Bef, Aft) -> + unicode:characters_to_list(reverse(Bef, Aft)). + +%% Grapheme length in codepoints +gc_len(CP) when is_integer(CP) -> 1; +gc_len(CPs) when is_list(CPs) -> length(CPs). + +%% String length in codepoints +cp_len(Str) -> + cp_len(Str, 0). + +cp_len([GC|R], Len) -> + cp_len(R, Len + gc_len(GC)); +cp_len([], Len) -> Len. %% %% expand(CurrentBefore) -> %% %% {yes,Expansion} | no diff --git a/lib/stdlib/src/edlin_expand.erl b/lib/stdlib/src/edlin_expand.erl index 6dd736da4c..bdcefda6e5 100644 --- a/lib/stdlib/src/edlin_expand.erl +++ b/lib/stdlib/src/edlin_expand.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2005-2010. All Rights Reserved. +%% Copyright Ericsson AB 2005-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -23,7 +23,7 @@ -export([expand/1, format_matches/1]). --import(lists, [reverse/1, nthtail/2, prefix/2]). +-import(lists, [reverse/1, prefix/2]). %% expand(CurrentBefore) -> %% {yes, Expansion, Matches} | {no, Matches} @@ -75,15 +75,15 @@ to_atom(Str) -> end. match(Prefix, Alts, Extra0) -> - Len = length(Prefix), + Len = string:length(Prefix), Matches = lists:sort( [{S, A} || {H, A} <- Alts, - prefix(Prefix, S=hd(io_lib:fwrite("~w",[H])))]), + prefix(Prefix, S=flat_write(H))]), case longest_common_head([N || {N, _} <- Matches]) of {partial, []} -> {no, [], Matches}; % format_matches(Matches)}; {partial, Str} -> - case nthtail(Len, Str) of + case string:slice(Str, Len) of [] -> {yes, [], Matches}; % format_matches(Matches)}; Remain -> @@ -94,52 +94,89 @@ match(Prefix, Alts, Extra0) -> {"(",[{Str,0}]} -> "()"; {_,_} -> Extra0 end, - {yes, nthtail(Len, Str) ++ Extra, []}; + {yes, string:slice(Str, Len) ++ Extra, []}; no -> {no, [], []} end. +flat_write(T) -> + lists:flatten(io_lib:fwrite("~tw",[T])). + %% Return the list of names L in multiple columns. format_matches(L) -> - S = format_col(lists:sort(L), []), + {S1, Dots} = format_col(lists:sort(L), []), + S = case Dots of + true -> + {_, Prefix} = longest_common_head(vals(L)), + PrefixLen = string:length(Prefix), + case PrefixLen =< 3 of + true -> S1; % Do not replace the prefix with "...". + false -> + LeadingDotsL = leading_dots(L, PrefixLen), + {S2, _} = format_col(lists:sort(LeadingDotsL), []), + S2 + end; + false -> S1 + end, ["\n" | S]. format_col([], _) -> []; -format_col(L, Acc) -> format_col(L, field_width(L), 0, Acc). - -format_col(X, Width, Len, Acc) when Width + Len > 79 -> - format_col(X, Width, 0, ["\n" | Acc]); -format_col([A|T], Width, Len, Acc0) -> - H = case A of - %% If it's a tuple {string(), integer()}, we assume it's an - %% arity, and meant to be printed. - {H0, I} when is_integer(I) -> - H0 ++ "/" ++ integer_to_list(I); - {H1, _} -> H1; - H2 -> H2 - end, - Acc = [io_lib:format("~-*s", [Width,H]) | Acc0], - format_col(T, Width, Len+Width, Acc); -format_col([], _, _, Acc) -> - lists:reverse(Acc, "\n"). - -field_width(L) -> field_width(L, 0). - -field_width([{H,_}|T], W) -> - case length(H) of - L when L > W -> field_width(T, L); - _ -> field_width(T, W) +format_col(L, Acc) -> + LL = 79, + format_col(L, field_width(L, LL), 0, Acc, LL, false). + +format_col(X, Width, Len, Acc, LL, Dots) when Width + Len > LL -> + format_col(X, Width, 0, ["\n" | Acc], LL, Dots); +format_col([A|T], Width, Len, Acc0, LL, Dots) -> + {H0, R} = format_val(A), + Hmax = LL - length(R), + {H, NewDots} = + case string:length(H0) > Hmax of + true -> {io_lib:format("~-*ts", [Hmax - 3, H0]) ++ "...", true}; + false -> {H0, Dots} + end, + Acc = [io_lib:format("~-*ts", [Width, H ++ R]) | Acc0], + format_col(T, Width, Len+Width, Acc, LL, NewDots); +format_col([], _, _, Acc, _LL, Dots) -> + {lists:reverse(Acc, "\n"), Dots}. + +format_val({H, I}) when is_integer(I) -> + %% If it's a tuple {string(), integer()}, we assume it's an + %% arity, and meant to be printed. + {H, "/" ++ integer_to_list(I)}; +format_val({H, _}) -> + {H, ""}; +format_val(H) -> + {H, ""}. + +field_width(L, LL) -> field_width(L, 0, LL). + +field_width([{H,_}|T], W, LL) -> + case string:length(H) of + L when L > W -> field_width(T, L, LL); + _ -> field_width(T, W, LL) end; -field_width([H|T], W) -> - case length(H) of - L when L > W -> field_width(T, L); - _ -> field_width(T, W) +field_width([H|T], W, LL) -> + case string:length(H) of + L when L > W -> field_width(T, L, LL); + _ -> field_width(T, W, LL) end; -field_width([], W) when W < 40 -> +field_width([], W, LL) when W < LL - 3 -> W + 4; -field_width([], _) -> - 40. +field_width([], _, LL) -> + LL. + +vals([]) -> []; +vals([{S, _}|L]) -> [S|vals(L)]; +vals([S|L]) -> [S|vals(L)]. + +leading_dots([], _Len) -> []; +leading_dots([{H, I}|L], Len) -> + [{"..." ++ string:slice(H, Len), I}|leading_dots(L, Len)]; +leading_dots([H|L], Len) -> + ["..." ++ string:slice(H, Len)|leading_dots(L, Len)]. +%% Strings are handled naively, but it should be OK here. longest_common_head([]) -> no; longest_common_head(LL) -> diff --git a/lib/stdlib/src/epp.erl b/lib/stdlib/src/epp.erl index d3124ac593..b8e48bff6c 100644 --- a/lib/stdlib/src/epp.erl +++ b/lib/stdlib/src/epp.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2015. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -40,16 +40,26 @@ -type ifdef() :: 'ifdef' | 'ifndef' | 'else'. --type name() :: {'atom', atom()}. +-type name() :: atom(). -type argspec() :: 'none' %No arguments | non_neg_integer(). %Number of arguments +-type argnames() :: [atom()]. -type tokens() :: [erl_scan:token()]. +-type predef() :: 'undefined' | {'none', tokens()}. +-type userdef() :: {argspec(), {argnames(), tokens()}}. -type used() :: {name(), argspec()}. +-type function_name_type() :: 'undefined' + | {atom(),non_neg_integer()} + | tokens(). + +-type warning_info() :: {erl_anno:location(), module(), term()}. + -define(DEFAULT_ENCODING, utf8). %% Epp state record. --record(epp, {file :: file:io_device(), %Current file +-record(epp, {file :: file:io_device() + | 'undefined', %Current file location=1, %Current location delta=0 :: non_neg_integer(), %Offset from Location (-file) name="" :: file:name(), %Current file name @@ -57,21 +67,15 @@ istk=[] :: [ifdef()], %Ifdef stack sstk=[] :: [#epp{}], %State stack path=[] :: [file:name()], %Include-path - macs = dict:new() %Macros (don't care locations) - :: dict:dict(name(), {argspec(), tokens()}), - uses = dict:new() %Macro use structure - :: dict:dict(name(), [{argspec(), [used()]}]), + macs = #{} %Macros (don't care locations) + :: #{name() => predef() | [userdef()]}, + uses = #{} %Macro use structure + :: #{name() => [{argspec(), [used()]}]}, default_encoding = ?DEFAULT_ENCODING :: source_encoding(), - pre_opened = false :: boolean() + pre_opened = false :: boolean(), + fname = [] :: function_name_type() }). -%%% Note on representation: as tokens, both {var, Location, Name} and -%%% {atom, Location, Name} can occur as macro identifiers. However, keeping -%%% this distinction here is done for historical reasons only: previously, -%%% ?FOO and ?'FOO' were not the same, but now they are. Removing the -%%% distinction in the internal representation would simplify the code -%%% a little. - %% open(Options) %% open(FileName, IncludePath) %% open(FileName, IncludePath, PreDefMacros) @@ -156,11 +160,13 @@ scan_erl_form(Epp) -> epp_request(Epp, scan_erl_form). -spec parse_erl_form(Epp) -> - {'ok', AbsForm} | {'eof', Line} | {error, ErrorInfo} when + {'ok', AbsForm} | {error, ErrorInfo} | + {'warning',WarningInfo} | {'eof',Line} when Epp :: epp_handle(), AbsForm :: erl_parse:abstract_form(), Line :: erl_anno:line(), - ErrorInfo :: erl_scan:error_info() | erl_parse:error_info(). + ErrorInfo :: erl_scan:error_info() | erl_parse:error_info(), + WarningInfo :: warning_info(). parse_erl_form(Epp) -> case epp_request(Epp, scan_erl_form) of @@ -188,31 +194,39 @@ format_error(missing_parenthesis) -> format_error(premature_end) -> "premature end"; format_error({call,What}) -> - io_lib:format("illegal macro call '~s'",[What]); + io_lib:format("illegal macro call '~ts'",[What]); format_error({undefined,M,none}) -> - io_lib:format("undefined macro '~s'", [M]); + io_lib:format("undefined macro '~ts'", [M]); format_error({undefined,M,A}) -> - io_lib:format("undefined macro '~s/~p'", [M,A]); + io_lib:format("undefined macro '~ts/~p'", [M,A]); format_error({depth,What}) -> io_lib:format("~s too deep",[What]); format_error({mismatch,M}) -> - io_lib:format("argument mismatch for macro '~s'", [M]); + io_lib:format("argument mismatch for macro '~ts'", [M]); format_error({arg_error,M}) -> - io_lib:format("badly formed argument for macro '~s'", [M]); + io_lib:format("badly formed argument for macro '~ts'", [M]); format_error({redefine,M}) -> - io_lib:format("redefining macro '~s'", [M]); + io_lib:format("redefining macro '~ts'", [M]); format_error({redefine_predef,M}) -> io_lib:format("redefining predefined macro '~s'", [M]); format_error({circular,M,none}) -> - io_lib:format("circular macro '~s'", [M]); + io_lib:format("circular macro '~ts'", [M]); format_error({circular,M,A}) -> - io_lib:format("circular macro '~s/~p'", [M,A]); + io_lib:format("circular macro '~ts/~p'", [M,A]); format_error({include,W,F}) -> - io_lib:format("can't find include ~s \"~s\"", [W,F]); + io_lib:format("can't find include ~s \"~ts\"", [W,F]); format_error({illegal,How,What}) -> io_lib:format("~s '-~s'", [How,What]); +format_error({illegal_function,Macro}) -> + io_lib:format("?~s can only be used within a function", [Macro]); +format_error({illegal_function_usage,Macro}) -> + io_lib:format("?~s must not begin a form", [Macro]); format_error({'NYI',What}) -> io_lib:format("not yet implemented '~s'", [What]); +format_error({error,Term}) -> + io_lib:format("-error(~tp).", [Term]); +format_error({warning,Term}) -> + io_lib:format("-warning(~tp).", [Term]); format_error(E) -> file:format_error(E). -spec parse_file(FileName, IncludePath, PredefMacros) -> @@ -257,31 +271,22 @@ parse_file(Ifile, Options) -> -spec parse_file(Epp) -> [Form] when Epp :: epp_handle(), - Form :: erl_parse:abstract_form() | {'error', ErrorInfo} | {'eof',Line}, + Form :: erl_parse:abstract_form() | {'error', ErrorInfo} | + {'warning',WarningInfo} | {'eof',Line}, Line :: erl_anno:line(), - ErrorInfo :: erl_scan:error_info() | erl_parse:error_info(). + ErrorInfo :: erl_scan:error_info() | erl_parse:error_info(), + WarningInfo :: warning_info(). parse_file(Epp) -> case parse_erl_form(Epp) of {ok,Form} -> - case Form of - {attribute,La,record,{Record, Fields}} -> - case normalize_typed_record_fields(Fields) of - {typed, NewFields} -> - [{attribute, La, record, {Record, NewFields}}, - {attribute, La, type, - {{record, Record}, Fields, []}} - |parse_file(Epp)]; - not_typed -> - [Form|parse_file(Epp)] - end; - _ -> - [Form|parse_file(Epp)] - end; + [Form|parse_file(Epp)]; {error,E} -> [{error,E}|parse_file(Epp)]; + {warning,W} -> + [{warning,W}|parse_file(Epp)]; {eof,Location} -> - [{eof,erl_anno:new(Location)}] + [{eof,Location}] end. -spec default_encoding() -> source_encoding(). @@ -549,7 +554,8 @@ init_server(Pid, Name, Options, St0) -> default_encoding=DefEncoding}, From = wait_request(St), Anno = erl_anno:new(AtLocation), - enter_file_reply(From, Name, Anno, AtLocation, code), + enter_file_reply(From, file_name(Name), Anno, + AtLocation, code), wait_req_scan(St); {error,E} -> epp_reply(Pid, {error,E}) @@ -560,18 +566,20 @@ init_server(Pid, Name, Options, St0) -> %% FILE, LINE, MODULE as undefined, MACHINE and MACHINE value. predef_macros(File) -> - Machine = list_to_atom(erlang:system_info(machine)), - Anno = line1(), - dict:from_list([ - {{atom,'FILE'}, {none,[{string,Anno,File}]}}, - {{atom,'LINE'}, {none,[{integer,Anno,1}]}}, - {{atom,'MODULE'}, undefined}, - {{atom,'MODULE_STRING'}, undefined}, - {{atom,'BASE_MODULE'}, undefined}, - {{atom,'BASE_MODULE_STRING'}, undefined}, - {{atom,'MACHINE'}, {none,[{atom,Anno,Machine}]}}, - {{atom,Machine}, {none,[{atom,Anno,true}]}} - ]). + Machine = list_to_atom(erlang:system_info(machine)), + Anno = line1(), + Defs = [{'FILE', {none,[{string,Anno,File}]}}, + {'FUNCTION_NAME', undefined}, + {'FUNCTION_ARITY', undefined}, + {'LINE', {none,[{integer,Anno,1}]}}, + {'MODULE', undefined}, + {'MODULE_STRING', undefined}, + {'BASE_MODULE', undefined}, + {'BASE_MODULE_STRING', undefined}, + {'MACHINE', {none,[{atom,Anno,Machine}]}}, + {Machine, {none,[{atom,Anno,true}]}} + ], + maps:from_list(Defs). %% user_predef(PreDefMacros, Macros) -> %% {ok,MacroDict} | {error,E} @@ -580,28 +588,21 @@ predef_macros(File) -> user_predef([{M,Val,redefine}|Pdm], Ms) when is_atom(M) -> Exp = erl_parse:tokens(erl_parse:abstract(Val)), - user_predef(Pdm, dict:store({atom,M}, {none,Exp}, Ms)); + user_predef(Pdm, Ms#{M=>{none,Exp}}); user_predef([{M,Val}|Pdm], Ms) when is_atom(M) -> - case dict:find({atom,M}, Ms) of - {ok,_Defs} when is_list(_Defs) -> %% User defined macros + case Ms of + #{M:=Defs} when is_list(Defs) -> + %% User defined macros. {error,{redefine,M}}; - {ok,_Def} -> %% Predefined macros + #{M:=_Defs} -> + %% Predefined macros. {error,{redefine_predef,M}}; - error -> + _ -> Exp = erl_parse:tokens(erl_parse:abstract(Val)), - user_predef(Pdm, dict:store({atom,M}, [{none, {none,Exp}}], Ms)) + user_predef(Pdm, Ms#{M=>[{none,{none,Exp}}]}) end; user_predef([M|Pdm], Ms) when is_atom(M) -> - case dict:find({atom,M}, Ms) of - {ok,_Defs} when is_list(_Defs) -> %% User defined macros - {error,{redefine,M}}; - {ok,_Def} -> %% Predefined macros - {error,{redefine_predef,M}}; - error -> - A = line1(), - user_predef(Pdm, - dict:store({atom,M}, [{none, {none,[{atom,A,true}]}}], Ms)) - end; + user_predef([{M,true}|Pdm], Ms); user_predef([Md|_Pdm], _Ms) -> {error,{bad,Md}}; user_predef([], Ms) -> {ok,Ms}. @@ -615,7 +616,9 @@ wait_request(St) -> receive {epp_request,From,scan_erl_form} -> From; {epp_request,From,macro_defs} -> - epp_reply(From, dict:to_list(St#epp.macs)), + %% Return the old format to avoid any incompability issues. + Defs = [{{atom,K},V} || {K,V} <- maps:to_list(St#epp.macs)], + epp_reply(From, Defs), wait_request(St); {epp_request,From,close} -> close_file(St), @@ -667,7 +670,8 @@ enter_file(NewName, Inc, From, St) -> enter_file2(NewF, Pname, From, St0, AtLocation) -> Anno = erl_anno:new(AtLocation), enter_file_reply(From, Pname, Anno, AtLocation, code), - Ms = dict:store({atom,'FILE'}, {none,[{string,Anno,Pname}]}, St0#epp.macs), + Ms0 = St0#epp.macs, + Ms = Ms0#{'FILE':={none,[{string,Anno,Pname}]}}, %% update the head of the include path to be the directory of the new %% source file, so that an included file can always include other files %% relative to its current location (this is also how C does it); note @@ -688,7 +692,7 @@ enter_file_reply(From, Name, LocationAnno, AtLocation, Where) -> generated -> erl_anno:set_generated(true, Anno0) end, Rep = {ok, [{'-',Anno},{atom,Anno,file},{'(',Anno}, - {string,Anno,file_name(Name)},{',',Anno}, + {string,Anno,Name},{',',Anno}, {integer,Anno,get_line(LocationAnno)},{')',LocationAnno}, {dot,Anno}]}, epp_reply(From, Rep). @@ -719,9 +723,8 @@ leave_file(From, St) -> name2=OldName2} = OldSt, CurrLoc = add_line(OldLoc, Delta), Anno = erl_anno:new(CurrLoc), - Ms = dict:store({atom,'FILE'}, - {none,[{string,Anno,OldName2}]}, - St#epp.macs), + Ms0 = St#epp.macs, + Ms = Ms0#{'FILE':={none,[{string,Anno,OldName2}]}}, NextSt = OldSt#epp{sstk=Sts,macs=Ms,uses=St#epp.uses}, enter_file_reply(From, OldName, Anno, CurrLoc, code), case OldName2 =:= OldName of @@ -761,6 +764,10 @@ scan_toks([{'-',_Lh},{atom,_Ld,define}=Define|Toks], From, St) -> scan_define(Toks, Define, From, St); scan_toks([{'-',_Lh},{atom,_Ld,undef}=Undef|Toks], From, St) -> scan_undef(Toks, Undef, From, St); +scan_toks([{'-',_Lh},{atom,_Ld,error}=Error|Toks], From, St) -> + scan_err_warn(Toks, Error, From, St); +scan_toks([{'-',_Lh},{atom,_Ld,warning}=Warn|Toks], From, St) -> + scan_err_warn(Toks, Warn, From, St); scan_toks([{'-',_Lh},{atom,_Li,include}=Inc|Toks], From, St) -> scan_include(Toks, Inc, From, St); scan_toks([{'-',_Lh},{atom,_Li,include_lib}=IncLib|Toks], From, St) -> @@ -778,7 +785,7 @@ scan_toks([{'-',_Lh},{atom,_Le,elif}=Elif|Toks], From, St) -> scan_toks([{'-',_Lh},{atom,_Le,endif}=Endif|Toks], From, St) -> scan_endif(Toks, Endif, From, St); scan_toks([{'-',_Lh},{atom,_Lf,file}=FileToken|Toks0], From, St) -> - case catch expand_macros(Toks0, {St#epp.macs, St#epp.uses}) of + case catch expand_macros(Toks0, St) of Toks1 when is_list(Toks1) -> scan_file(Toks1, FileToken, From, St); {error,ErrL,What} -> @@ -786,7 +793,7 @@ scan_toks([{'-',_Lh},{atom,_Lf,file}=FileToken|Toks0], From, St) -> wait_req_scan(St) end; scan_toks(Toks0, From, St) -> - case catch expand_macros(Toks0, {St#epp.macs, St#epp.uses}) of + case catch expand_macros(Toks0, St#epp{fname=Toks0}) of Toks1 when is_list(Toks1) -> epp_reply(From, {ok,Toks1}), wait_req_scan(St#epp{macs=scan_module(Toks1, St#epp.macs)}); @@ -796,91 +803,66 @@ scan_toks(Toks0, From, St) -> end. scan_module([{'-',_Lh},{atom,_Lm,module},{'(',_Ll}|Ts], Ms) -> - scan_module_1(Ts, [], Ms); + scan_module_1(Ts, Ms); scan_module([{'-',_Lh},{atom,_Lm,extends},{'(',_Ll}|Ts], Ms) -> - scan_extends(Ts, [], Ms); + scan_extends(Ts, Ms); scan_module(_Ts, Ms) -> Ms. -scan_module_1([{atom,_,_}=A,{',',L}|Ts], As, Ms) -> +scan_module_1([{atom,_,_}=A,{',',L}|Ts], Ms) -> %% Parameterized modules. - scan_module_1([A,{')',L}|Ts], As, Ms); -scan_module_1([{atom,Ln,A},{')',_Lr}|_Ts], As, Ms0) -> - Mod = lists:concat(lists:reverse([A|As])), - Ms = dict:store({atom,'MODULE'}, - {none,[{atom,Ln,list_to_atom(Mod)}]}, Ms0), - dict:store({atom,'MODULE_STRING'}, {none,[{string,Ln,Mod}]}, Ms); -scan_module_1([{atom,_Ln,A},{'.',_Lr}|Ts], As, Ms) -> - scan_module_1(Ts, [".",A|As], Ms); -scan_module_1([{'.',_Lr}|Ts], As, Ms) -> - scan_module_1(Ts, As, Ms); -scan_module_1(_Ts, _As, Ms) -> Ms. - -scan_extends([{atom,Ln,A},{')',_Lr}|_Ts], As, Ms0) -> - Mod = lists:concat(lists:reverse([A|As])), - Ms = dict:store({atom,'BASE_MODULE'}, - {none,[{atom,Ln,list_to_atom(Mod)}]}, Ms0), - dict:store({atom,'BASE_MODULE_STRING'}, {none,[{string,Ln,Mod}]}, Ms); -scan_extends([{atom,_Ln,A},{'.',_Lr}|Ts], As, Ms) -> - scan_extends(Ts, [".",A|As], Ms); -scan_extends([{'.',_Lr}|Ts], As, Ms) -> - scan_extends(Ts, As, Ms); -scan_extends(_Ts, _As, Ms) -> Ms. + scan_module_1([A,{')',L}|Ts], Ms); +scan_module_1([{atom,Ln,A}=ModAtom,{')',_Lr}|_Ts], Ms0) -> + ModString = atom_to_list(A), + Ms = Ms0#{'MODULE':={none,[ModAtom]}}, + Ms#{'MODULE_STRING':={none,[{string,Ln,ModString}]}}; +scan_module_1(_Ts, Ms) -> Ms. + +scan_extends([{atom,Ln,A}=ModAtom,{')',_Lr}|_Ts], Ms0) -> + ModString = atom_to_list(A), + Ms = Ms0#{'BASE_MODULE':={none,[ModAtom]}}, + Ms#{'BASE_MODULE_STRING':={none,[{string,Ln,ModString}]}}; +scan_extends(_Ts, Ms) -> Ms. + +scan_err_warn([{'(',_}|_]=Toks0, {atom,_,Tag}=Token, From, St) -> + try expand_macros(Toks0, St) of + Toks when is_list(Toks) -> + case erl_parse:parse_term(Toks) of + {ok,Term} -> + epp_reply(From, {Tag,{loc(Token),epp,{Tag,Term}}}); + {error,_} -> + epp_reply(From, {error,{loc(Token),epp,{bad,Tag}}}) + end + catch + _:_ -> + epp_reply(From, {error,{loc(Token),epp,{bad,Tag}}}) + end, + wait_req_scan(St); +scan_err_warn(_Toks, {atom,_,Tag}=Token, From, St) -> + epp_reply(From, {error,{loc(Token),epp,{bad,Tag}}}), + wait_req_scan(St). %% scan_define(Tokens, DefineToken, From, EppState) -scan_define([{'(',_Lp},{Type,_Lm,M}=Mac,{',',_}=Comma|Toks], _Def, From, St) +scan_define([{'(',_Lp},{Type,_Lm,_}=Mac|Toks], Def, From, St) when Type =:= atom; Type =:= var -> + scan_define_1(Toks, Mac, Def, From, St); +scan_define(_Toks, Def, From, St) -> + epp_reply(From, {error,{loc(Def),epp,{bad,define}}}), + wait_req_scan(St). + +scan_define_1([{',',_}=Comma|Toks], Mac,_Def, From, St) -> case catch macro_expansion(Toks, Comma) of Expansion when is_list(Expansion) -> - case dict:find({atom,M}, St#epp.macs) of - {ok, Defs} when is_list(Defs) -> - %% User defined macros: can be overloaded - case proplists:is_defined(none, Defs) of - true -> - epp_reply(From, {error,{loc(Mac),epp,{redefine,M}}}), - wait_req_scan(St); - false -> - scan_define_cont(From, St, - {atom, M}, - {none, {none,Expansion}}) - end; - {ok, _PreDef} -> - %% Predefined macros: cannot be overloaded - epp_reply(From, {error,{loc(Mac),epp,{redefine_predef,M}}}), - wait_req_scan(St); - error -> - scan_define_cont(From, St, - {atom, M}, - {none, {none,Expansion}}) - end; + scan_define_2(none, {none,Expansion}, Mac, From, St); {error,ErrL,What} -> epp_reply(From, {error,{ErrL,epp,What}}), wait_req_scan(St) end; -scan_define([{'(',_Lp},{Type,_Lm,M}=Mac,{'(',_Lc}|Toks], Def, From, St) - when Type =:= atom; Type =:= var -> +scan_define_1([{'(',_Lc}|Toks], Mac, Def, From, St) -> case catch macro_pars(Toks, []) of - {ok, {As,Me}} -> + {ok,{As,_}=MacroDef} -> Len = length(As), - case dict:find({atom,M}, St#epp.macs) of - {ok, Defs} when is_list(Defs) -> - %% User defined macros: can be overloaded - case proplists:is_defined(Len, Defs) of - true -> - epp_reply(From,{error,{loc(Mac),epp,{redefine,M}}}), - wait_req_scan(St); - false -> - scan_define_cont(From, St, {atom, M}, - {Len, {As, Me}}) - end; - {ok, _PreDef} -> - %% Predefined macros: cannot be overloaded - %% (There are currently no predefined F(...) macros.) - epp_reply(From, {error,{loc(Mac),epp,{redefine_predef,M}}}), - wait_req_scan(St); - error -> - scan_define_cont(From, St, {atom, M}, {Len, {As, Me}}) - end; + scan_define_2(Len, MacroDef, Mac, From, St); {error,ErrL,What} -> epp_reply(From, {error,{ErrL,epp,What}}), wait_req_scan(St); @@ -888,10 +870,29 @@ scan_define([{'(',_Lp},{Type,_Lm,M}=Mac,{'(',_Lc}|Toks], Def, From, St) epp_reply(From, {error,{loc(Def),epp,{bad,define}}}), wait_req_scan(St) end; -scan_define(_Toks, Def, From, St) -> +scan_define_1(_Toks, _Mac, Def, From, St) -> epp_reply(From, {error,{loc(Def),epp,{bad,define}}}), wait_req_scan(St). +scan_define_2(Arity, Def, {_,_,Key}=Mac, From, #epp{macs=Ms}=St) -> + case Ms of + #{Key:=Defs} when is_list(Defs) -> + %% User defined macros: can be overloaded + case proplists:is_defined(Arity, Defs) of + true -> + epp_reply(From, {error,{loc(Mac),epp,{redefine,Key}}}), + wait_req_scan(St); + false -> + scan_define_cont(From, St, Key, Defs, Arity, Def) + end; + #{Key:=_} -> + %% Predefined macros: cannot be overloaded + epp_reply(From, {error,{loc(Mac),epp,{redefine_predef,Key}}}), + wait_req_scan(St); + _ -> + scan_define_cont(From, St, Key, [], Arity, Def) + end. + %%% Detection of circular macro expansions (which would either keep %%% the compiler looping forever, or run out of memory): %%% When a macro is defined, we store the names of other macros it @@ -901,11 +902,17 @@ scan_define(_Toks, Def, From, St) -> %%% the information from St#epp.uses is traversed, and if a circularity %%% is detected, an error message is thrown. -scan_define_cont(F, St, M, {Arity, Def}) -> - Ms = dict:append_list(M, [{Arity, Def}], St#epp.macs), - try dict:append_list(M, [{Arity, macro_uses(Def)}], St#epp.uses) of +scan_define_cont(F, #epp{macs=Ms0}=St, M, Defs, Arity, Def) -> + Ms = Ms0#{M=>[{Arity,Def}|Defs]}, + try macro_uses(Def) of U -> - scan_toks(F, St#epp{uses=U, macs=Ms}) + Uses0 = St#epp.uses, + Val = [{Arity,U}|case Uses0 of + #{M:=UseList} -> UseList; + _ -> [] + end], + Uses = Uses0#{M=>Val}, + scan_toks(F, St#epp{uses=Uses,macs=Ms}) catch {error, Line, Reason} -> epp_reply(F, {error,{Line,epp,Reason}}), @@ -923,23 +930,23 @@ macro_ref([{'?', _}, {'?', _} | Rest]) -> macro_ref([{'?', _}, {atom, _, A}=Atom | Rest]) -> Lm = loc(Atom), Arity = count_args(Rest, Lm, A), - [{{atom, A}, Arity} | macro_ref(Rest)]; + [{A,Arity} | macro_ref(Rest)]; macro_ref([{'?', _}, {var, _, A}=Var | Rest]) -> Lm = loc(Var), Arity = count_args(Rest, Lm, A), - [{{atom, A}, Arity} | macro_ref(Rest)]; + [{A,Arity} | macro_ref(Rest)]; macro_ref([_Token | Rest]) -> macro_ref(Rest). %% scan_undef(Tokens, UndefToken, From, EppState) scan_undef([{'(',_Llp},{atom,_Lm,M},{')',_Lrp},{dot,_Ld}], _Undef, From, St) -> - Macs = dict:erase({atom,M}, St#epp.macs), - Uses = dict:erase({atom,M}, St#epp.uses), + Macs = maps:remove(M, St#epp.macs), + Uses = maps:remove(M, St#epp.uses), scan_toks(From, St#epp{macs=Macs, uses=Uses}); scan_undef([{'(',_Llp},{var,_Lm,M},{')',_Lrp},{dot,_Ld}], _Undef, From,St) -> - Macs = dict:erase({atom,M}, St#epp.macs), - Uses = dict:erase({atom,M}, St#epp.uses), + Macs = maps:remove(M, St#epp.macs), + Uses = maps:remove(M, St#epp.uses), scan_toks(From, St#epp{macs=Macs, uses=Uses}); scan_undef(_Toks, Undef, From, St) -> epp_reply(From, {error,{loc(Undef),epp,{bad,undef}}}), @@ -947,11 +954,15 @@ scan_undef(_Toks, Undef, From, St) -> %% scan_include(Tokens, IncludeToken, From, St) -scan_include([{'(',_Llp},{string,_Lf,NewName0},{')',_Lrp},{dot,_Ld}], Inc, - From, St) -> +scan_include(Tokens0, Inc, From, St) -> + Tokens = coalesce_strings(Tokens0), + scan_include1(Tokens, Inc, From, St). + +scan_include1([{'(',_Llp},{string,_Lf,NewName0},{')',_Lrp},{dot,_Ld}], Inc, + From, St) -> NewName = expand_var(NewName0), enter_file(NewName, Inc, From, St); -scan_include(_Toks, Inc, From, St) -> +scan_include1(_Toks, Inc, From, St) -> epp_reply(From, {error,{loc(Inc),epp,{bad,include}}}), wait_req_scan(St). @@ -960,29 +971,38 @@ scan_include(_Toks, Inc, From, St) -> %% normal search path, if not we assume that the first directory name %% is a library name, find its true directory and try with that. -find_lib_dir(NewName) -> - [Lib | Rest] = filename:split(NewName), - {code:lib_dir(list_to_atom(Lib)), Rest}. +expand_lib_dir(Name) -> + try + [App|Path] = filename:split(Name), + LibDir = code:lib_dir(list_to_atom(App)), + {ok,fname_join([LibDir|Path])} + catch + _:_ -> + error + end. + +scan_include_lib(Tokens0, Inc, From, St) -> + Tokens = coalesce_strings(Tokens0), + scan_include_lib1(Tokens, Inc, From, St). -scan_include_lib([{'(',_Llp},{string,_Lf,_NewName0},{')',_Lrp},{dot,_Ld}], - Inc, From, St) +scan_include_lib1([{'(',_Llp},{string,_Lf,_NewName0},{')',_Lrp},{dot,_Ld}], + Inc, From, St) when length(St#epp.sstk) >= 8 -> epp_reply(From, {error,{loc(Inc),epp,{depth,"include_lib"}}}), wait_req_scan(St); -scan_include_lib([{'(',_Llp},{string,_Lf,NewName0},{')',_Lrp},{dot,_Ld}], - Inc, From, St) -> +scan_include_lib1([{'(',_Llp},{string,_Lf,NewName0},{')',_Lrp},{dot,_Ld}], + Inc, From, St) -> NewName = expand_var(NewName0), Loc = start_loc(St#epp.location), case file:path_open(St#epp.path, NewName, [read]) of {ok,NewF,Pname} -> wait_req_scan(enter_file2(NewF, Pname, From, St, Loc)); {error,_E1} -> - case catch find_lib_dir(NewName) of - {LibDir, Rest} when is_list(LibDir) -> - LibName = fname_join([LibDir | Rest]), - case file:open(LibName, [read]) of + case expand_lib_dir(NewName) of + {ok,Header} -> + case file:open(Header, [read]) of {ok,NewF} -> - wait_req_scan(enter_file2(NewF, LibName, From, + wait_req_scan(enter_file2(NewF, Header, From, St, Loc)); {error,_E2} -> epp_reply(From, @@ -990,13 +1010,13 @@ scan_include_lib([{'(',_Llp},{string,_Lf,NewName0},{')',_Lrp},{dot,_Ld}], {include,lib,NewName}}}), wait_req_scan(St) end; - _Error -> + error -> epp_reply(From, {error,{loc(Inc),epp, {include,lib,NewName}}}), wait_req_scan(St) end end; -scan_include_lib(_Toks, Inc, From, St) -> +scan_include_lib1(_Toks, Inc, From, St) -> epp_reply(From, {error,{loc(Inc),epp,{bad,include_lib}}}), wait_req_scan(St). @@ -1006,17 +1026,17 @@ scan_include_lib(_Toks, Inc, From, St) -> %% Report a badly formed if[n]def test and then treat as undefined macro. scan_ifdef([{'(',_Llp},{atom,_Lm,M},{')',_Lrp},{dot,_Ld}], _IfD, From, St) -> - case dict:find({atom,M}, St#epp.macs) of - {ok,_Def} -> + case St#epp.macs of + #{M:=_Def} -> scan_toks(From, St#epp{istk=[ifdef|St#epp.istk]}); - error -> + _ -> skip_toks(From, St, [ifdef]) end; scan_ifdef([{'(',_Llp},{var,_Lm,M},{')',_Lrp},{dot,_Ld}], _IfD, From, St) -> - case dict:find({atom,M}, St#epp.macs) of - {ok,_Def} -> + case St#epp.macs of + #{M:=_Def} -> scan_toks(From, St#epp{istk=[ifdef|St#epp.istk]}); - error -> + _ -> skip_toks(From, St, [ifdef]) end; scan_ifdef(_Toks, IfDef, From, St) -> @@ -1024,17 +1044,17 @@ scan_ifdef(_Toks, IfDef, From, St) -> wait_req_skip(St, [ifdef]). scan_ifndef([{'(',_Llp},{atom,_Lm,M},{')',_Lrp},{dot,_Ld}], _IfnD, From, St) -> - case dict:find({atom,M}, St#epp.macs) of - {ok,_Def} -> + case St#epp.macs of + #{M:=_Def} -> skip_toks(From, St, [ifndef]); - error -> + _ -> scan_toks(From, St#epp{istk=[ifndef|St#epp.istk]}) end; scan_ifndef([{'(',_Llp},{var,_Lm,M},{')',_Lrp},{dot,_Ld}], _IfnD, From, St) -> - case dict:find({atom,M}, St#epp.macs) of - {ok,_Def} -> + case St#epp.macs of + #{M:=_Def} -> skip_toks(From, St, [ifndef]); - error -> + _ -> scan_toks(From, St#epp{istk=[ifndef|St#epp.istk]}) end; scan_ifndef(_Toks, IfnDef, From, St) -> @@ -1098,16 +1118,21 @@ scan_endif(_Toks, Endif, From, St) -> %% Set the current file and line to the given file and line. %% Note that the line of the attribute itself is kept. -scan_file([{'(',_Llp},{string,_Ls,Name},{',',_Lc},{integer,_Li,Ln},{')',_Lrp}, - {dot,_Ld}], Tf, From, St) -> +scan_file(Tokens0, Tf, From, St) -> + Tokens = coalesce_strings(Tokens0), + scan_file1(Tokens, Tf, From, St). + +scan_file1([{'(',_Llp},{string,_Ls,Name},{',',_Lc},{integer,_Li,Ln},{')',_Lrp}, + {dot,_Ld}], Tf, From, St) -> Anno = erl_anno:new(Ln), enter_file_reply(From, Name, Anno, loc(Tf), generated), - Ms = dict:store({atom,'FILE'}, {none,[{string,line1(),Name}]}, St#epp.macs), + Ms0 = St#epp.macs, + Ms = Ms0#{'FILE':={none,[{string,line1(),Name}]}}, Locf = loc(Tf), NewLoc = new_location(Ln, St#epp.location, Locf), Delta = get_line(element(2, Tf))-Ln + St#epp.delta, wait_req_scan(St#epp{name2=Name,location=NewLoc,delta=Delta,macs=Ms}); -scan_file(_Toks, Tf, From, St) -> +scan_file1(_Toks, Tf, From, St) -> epp_reply(From, {error,{loc(Tf),epp,{bad,file}}}), wait_req_scan(St). @@ -1169,61 +1194,63 @@ skip_else(_Else, From, St, Sis) -> %% macro_expansion(Tokens, Anno) %% Extract the macro parameters and the expansion from a macro definition. -macro_pars([{')',_Lp}, {',',Ld}|Ex], Args) -> - {ok, {lists:reverse(Args), macro_expansion(Ex, Ld)}}; -macro_pars([{var,_,Name}, {')',_Lp}, {',',Ld}|Ex], Args) -> +macro_pars([{')',_Lp}, {',',_Ld}=Comma|Ex], Args) -> + {ok, {lists:reverse(Args), macro_expansion(Ex, Comma)}}; +macro_pars([{var,_,Name}, {')',_Lp}, {',',_Ld}=Comma|Ex], Args) -> false = lists:member(Name, Args), %Prolog is nice - {ok, {lists:reverse([Name|Args]), macro_expansion(Ex, Ld)}}; + {ok, {lists:reverse([Name|Args]), macro_expansion(Ex, Comma)}}; macro_pars([{var,_L,Name}, {',',_}|Ts], Args) -> false = lists:member(Name, Args), macro_pars(Ts, [Name|Args]). -macro_expansion([{')',_Lp},{dot,_Ld}], _Anno0) -> []; -macro_expansion([{dot,_}=Dot], _Anno0) -> +macro_expansion([{')',_Lp},{dot,_Ld}], _T0) -> []; +macro_expansion([{dot,_}=Dot], _T0) -> throw({error,loc(Dot),missing_parenthesis}); -macro_expansion([T|Ts], _Anno0) -> +macro_expansion([T|Ts], _T0) -> [T|macro_expansion(Ts, T)]; -macro_expansion([], Anno0) -> throw({error,loc(Anno0),premature_end}). +macro_expansion([], T0) -> throw({error,loc(T0),premature_end}). -%% expand_macros(Tokens, Macros) +%% expand_macros(Tokens, St) %% expand_macro(Tokens, MacroToken, RestTokens) %% Expand the macros in a list of tokens, making sure that an expansion %% gets the same location as the macro call. -expand_macros(Type, MacT, M, Toks, Ms0) -> - %% (Type will always be 'atom') - {Ms, U} = Ms0, +expand_macros(MacT, M, Toks, St) -> + #epp{macs=Ms,uses=U} = St, Lm = loc(MacT), Tinfo = element(2, MacT), - case expand_macro1(Type, Lm, M, Toks, Ms) of + case expand_macro1(Lm, M, Toks, Ms) of {ok,{none,Exp}} -> - check_uses([{{Type,M}, none}], [], U, Lm), - Toks1 = expand_macros(expand_macro(Exp, Tinfo, [], dict:new()), Ms0), - expand_macros(Toks1++Toks, Ms0); + check_uses([{M,none}], [], U, Lm), + Toks1 = expand_macros(expand_macro(Exp, Tinfo, [], #{}), St), + expand_macros(Toks1++Toks, St); {ok,{As,Exp}} -> - check_uses([{{Type,M}, length(As)}], [], U, Lm), - {Bs,Toks1} = bind_args(Toks, Lm, M, As, dict:new()), - expand_macros(expand_macro(Exp, Tinfo, Toks1, Bs), Ms0) + check_uses([{M,length(As)}], [], U, Lm), + {Bs,Toks1} = bind_args(Toks, Lm, M, As, #{}), + expand_macros(expand_macro(Exp, Tinfo, Toks1, Bs), St) end. -expand_macro1(Type, Lm, M, Toks, Ms) -> +expand_macro1(Lm, M, Toks, Ms) -> Arity = count_args(Toks, Lm, M), - case dict:find({Type,M}, Ms) of - error -> %% macro not found + case Ms of + #{M:=undefined} -> + %% Predefined macro without definition. throw({error,Lm,{undefined,M,Arity}}); - {ok, undefined} -> %% Predefined macro without definition - throw({error,Lm,{undefined,M,Arity}}); - {ok, [{none, Def}]} -> - {ok, Def}; - {ok, Defs} when is_list(Defs) -> - case proplists:get_value(Arity, Defs) of + #{M:=[{none,Def}]} -> + {ok,Def}; + #{M:=Defs} when is_list(Defs) -> + case proplists:get_value(Arity, Defs) of undefined -> throw({error,Lm,{mismatch,M}}); Def -> - {ok, Def} + {ok,Def} end; - {ok, PreDef} -> %% Predefined macro - {ok, PreDef} + #{M:=PreDef} -> + %% Predefined macro. + {ok,PreDef}; + _ -> + %% Macro not found. + throw({error,Lm,{undefined,M,Arity}}) end. check_uses([], _Anc, _U, _Lm) -> @@ -1231,7 +1258,7 @@ check_uses([], _Anc, _U, _Lm) -> check_uses([M|Rest], Anc, U, Lm) -> case lists:member(M, Anc) of true -> - {{_, Name},Arity} = M, + {Name,Arity} = M, throw({error,Lm,{circular,Name,Arity}}); false -> L = get_macro_uses(M, U), @@ -1240,36 +1267,52 @@ check_uses([M|Rest], Anc, U, Lm) -> end. get_macro_uses({M,Arity}, U) -> - case dict:find(M, U) of - error -> - []; - {ok, L} -> - proplists:get_value(Arity, L, proplists:get_value(none, L, [])) + case U of + #{M:=L} -> + proplists:get_value(Arity, L, proplists:get_value(none, L, [])); + _ -> + [] end. %% Macro expansion %% Note: io:scan_erl_form() does not return comments or white spaces. -expand_macros([{'?',_Lq},{atom,_Lm,M}=MacT|Toks], Ms) -> - expand_macros(atom, MacT, M, Toks, Ms); +expand_macros([{'?',_Lq},{atom,_Lm,M}=MacT|Toks], St) -> + expand_macros(MacT, M, Toks, St); %% Special macros -expand_macros([{'?',_Lq},{var,Lm,'LINE'}=Tok|Toks], Ms) -> +expand_macros([{'?',_Lq},{var,Lm,'FUNCTION_NAME'}=Token|Toks], St0) -> + St = update_fun_name(Token, St0), + case St#epp.fname of + undefined -> + [{'?',_Lq},Token]; + {Name,_} -> + [{atom,Lm,Name}] + end ++ expand_macros(Toks, St); +expand_macros([{'?',_Lq},{var,Lm,'FUNCTION_ARITY'}=Token|Toks], St0) -> + St = update_fun_name(Token, St0), + case St#epp.fname of + undefined -> + [{'?',_Lq},Token]; + {_,Arity} -> + [{integer,Lm,Arity}] + end ++ expand_macros(Toks, St); +expand_macros([{'?',_Lq},{var,Lm,'LINE'}=Tok|Toks], St) -> Line = erl_scan:line(Tok), - [{integer,Lm,Line}|expand_macros(Toks, Ms)]; -expand_macros([{'?',_Lq},{var,_Lm,M}=MacT|Toks], Ms) -> - expand_macros(atom, MacT, M, Toks, Ms); + [{integer,Lm,Line}|expand_macros(Toks, St)]; +expand_macros([{'?',_Lq},{var,_Lm,M}=MacT|Toks], St) -> + expand_macros(MacT, M, Toks, St); %% Illegal macros -expand_macros([{'?',_Lq},Token|_Toks], _Ms) -> +expand_macros([{'?',_Lq},Token|_Toks], _St) -> T = case erl_scan:text(Token) of Text when is_list(Text) -> Text; undefined -> Symbol = erl_scan:symbol(Token), - io_lib:write(Symbol) + io_lib:fwrite(<<"~tp">>, [Symbol]) end, throw({error,loc(Token),{call,[$?|T]}}); -expand_macros([T|Ts], Ms) -> - [T|expand_macros(Ts, Ms)]; -expand_macros([], _Ms) -> []. +expand_macros([T|Ts], St) -> + [T|expand_macros(Ts, St)]; +expand_macros([], _St) -> []. %% bind_args(Tokens, MacroLocation, MacroName, ArgumentVars, Bindings) %% Collect the arguments to a macro call. @@ -1295,7 +1338,7 @@ macro_args(_Toks, Lm, M, _As, _Bs) -> store_arg(L, M, _A, [], _Bs) -> throw({error,L,{mismatch,M}}); store_arg(_L, _M, A, Arg, Bs) -> - dict:store(A, Arg, Bs). + Bs#{A=>Arg}. %% count_args(Tokens, MacroLine, MacroName) %% Count the number of arguments in a macro call. @@ -1368,19 +1411,17 @@ macro_arg([], _E, Arg) -> %% and then the macro arguments, i.e. simulate textual expansion. expand_macro([{var,_Lv,V}|Ts], L, Rest, Bs) -> - case dict:find(V, Bs) of - {ok,Val} -> - %% lists:append(Val, expand_macro(Ts, L, Rest, Bs)); + case Bs of + #{V:=Val} -> expand_arg(Val, Ts, L, Rest, Bs); - error -> + _ -> [{var,L,V}|expand_macro(Ts, L, Rest, Bs)] end; expand_macro([{'?', _}, {'?', _}, {var,_Lv,V}|Ts], L, Rest, Bs) -> - case dict:find(V, Bs) of - {ok,Val} -> - %% lists:append(Val, expand_macro(Ts, L, Rest, Bs)); + case Bs of + #{V:=Val} -> expand_arg(stringify(Val, L), Ts, L, Rest, Bs); - error -> + _ -> [{var,L,V}|expand_macro(Ts, L, Rest, Bs)] end; expand_macro([T|Ts], L, Rest, Bs) -> @@ -1394,6 +1435,93 @@ expand_arg([A|As], Ts, _L, Rest, Bs) -> expand_arg([], Ts, L, Rest, Bs) -> expand_macro(Ts, L, Rest, Bs). +%%% +%%% Here follows support for the ?FUNCTION_NAME and ?FUNCTION_ARITY +%%% macros. Since the parser has not been run yet, we don't know the +%%% name and arity of the current function. Therefore, we will need to +%%% scan the beginning of the current form to extract the name and +%%% arity of the function. +%%% + +update_fun_name(Token, #epp{fname=Toks0}=St) when is_list(Toks0) -> + %% ?FUNCTION_NAME or ?FUNCTION_ARITY is used for the first time in + %% a function. First expand macros (except ?FUNCTION_NAME and + %% ?FUNCTION_ARITY) in the form. + + Toks1 = (catch expand_macros(Toks0, St#epp{fname=undefined})), + + %% Now extract the name and arity from the stream of tokens, and store + %% the result in the #epp{} record so we don't have to do it + %% again. + + case Toks1 of + [{atom,_,Name},{'(',_}|Toks] -> + %% This is the beginning of a function definition. + %% Scan the token stream up to the matching right + %% parenthesis and count the number of arguments. + FA = update_fun_name_1(Toks, 1, {Name,0}, St), + St#epp{fname=FA}; + [{'?',_}|_] -> + %% ?FUNCTION_NAME/?FUNCTION_ARITY used at the beginning + %% of a form. Does not make sense. + {var,_,Macro} = Token, + throw({error,loc(Token),{illegal_function_usage,Macro}}); + _ when is_list(Toks1) -> + %% Not the beginning of a function (an attribute or a + %% syntax error). + {var,_,Macro} = Token, + throw({error,loc(Token),{illegal_function,Macro}}); + _ -> + %% A macro expansion error. Return a dummy value and + %% let the caller notice and handle the error. + St#epp{fname={'_',0}} + end; +update_fun_name(_Token, St) -> + St. + +update_fun_name_1([Tok|Toks], L, FA, St) -> + case classify_token(Tok) of + comma -> + if + L =:= 1 -> + {Name,Arity} = FA, + update_fun_name_1(Toks, L, {Name,Arity+1}, St); + true -> + update_fun_name_1(Toks, L, FA, St) + end; + left -> + update_fun_name_1(Toks, L+1, FA, St); + right when L =:= 1 -> + FA; + right -> + update_fun_name_1(Toks, L-1, FA, St); + other -> + case FA of + {Name,0} -> + update_fun_name_1(Toks, L, {Name,1}, St); + {_,_} -> + update_fun_name_1(Toks, L, FA, St) + end + end; +update_fun_name_1([], _, FA, _) -> + %% Syntax error, but never mind. + FA. + +classify_token({C,_}) -> classify_token_1(C); +classify_token(_) -> other. + +classify_token_1(',') -> comma; +classify_token_1('(') -> left; +classify_token_1('{') -> left; +classify_token_1('[') -> left; +classify_token_1('<<') -> left; +classify_token_1(')') -> right; +classify_token_1('}') -> right; +classify_token_1(']') -> right; +classify_token_1('>>') -> right; +classify_token_1(_) -> other. + + %%% stringify(Ts, L) returns a list of one token: a string which when %%% tokenized would yield the token list Ts. @@ -1421,6 +1549,18 @@ stringify(Ts, L) -> [$\s | S] = lists:flatten(stringify1(Ts)), [{string, L, S}]. +coalesce_strings([{string,A,S} | Tokens]) -> + coalesce_strings(Tokens, A, [S]); +coalesce_strings([T | Tokens]) -> + [T | coalesce_strings(Tokens)]; +coalesce_strings([]) -> + []. + +coalesce_strings([{string,_,S}|Tokens], A, S0) -> + coalesce_strings(Tokens, A, [S | S0]); +coalesce_strings(Tokens, A, S) -> + [{string,A,lists:append(lists:reverse(S))} | coalesce_strings(Tokens)]. + %% epp_request(Epp) %% epp_request(Epp, Request) %% epp_reply(From, Reply) diff --git a/lib/stdlib/src/erl_abstract_code.erl b/lib/stdlib/src/erl_abstract_code.erl new file mode 100644 index 0000000000..6e45f11aa3 --- /dev/null +++ b/lib/stdlib/src/erl_abstract_code.erl @@ -0,0 +1,28 @@ +-module(erl_abstract_code). +-export([debug_info/4]). + +debug_info(_Format, _Module, {none,_CompilerOpts}, _Opts) -> + {error, missing}; +debug_info(erlang_v1, _Module, {AbstrCode,_CompilerOpts}, _Opts) -> + {ok, AbstrCode}; +debug_info(core_v1, _Module, {AbstrCode,CompilerOpts}, Opts) -> + CoreOpts = add_core_returns(delete_reports(CompilerOpts ++ Opts)), + try compile:noenv_forms(AbstrCode, CoreOpts) of + {ok, _, Core, _} -> {ok, Core}; + _What -> {error, failed_conversion} + catch + error:_ -> {error, failed_conversion} + end; +debug_info(_, _, _, _) -> + {error, unknown_format}. + +delete_reports(Opts) -> + [Opt || Opt <- Opts, not is_report_option(Opt)]. + +is_report_option(report) -> true; +is_report_option(report_errors) -> true; +is_report_option(report_warnings) -> true; +is_report_option(_) -> false. + +add_core_returns(Opts) -> + [to_core, return_errors, return_warnings] ++ Opts. diff --git a/lib/stdlib/src/erl_anno.erl b/lib/stdlib/src/erl_anno.erl index 143318aa55..d0310f52e2 100644 --- a/lib/stdlib/src/erl_anno.erl +++ b/lib/stdlib/src/erl_anno.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2015. All Rights Reserved. +%% Copyright Ericsson AB 1996-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -33,7 +33,7 @@ -export_type([anno_term/0]). --define(LN(L), is_integer(L)). +-define(LN(L), is_integer(L), L >= 0). -define(COL(C), (is_integer(C) andalso C >= 1)). %% Location. @@ -42,7 +42,7 @@ %% Debug: define DEBUG to make sure that annotations are handled as an %% opaque type. Note that all abstract code need to be compiled with -%% DEBUG=true. See also ./erl_pp.erl. +%% DEBUG=true. See also ./erl_pp.erl and ./erl_parse.yrl. %-define(DEBUG, true). @@ -52,13 +52,17 @@ | {'record', record()} | {'text', string()}. --type anno() :: location() | [annotation(), ...]. +-ifdef(DEBUG). +-opaque anno() :: [annotation(), ...]. +-else. +-opaque anno() :: location() | [annotation(), ...]. +-endif. -type anno_term() :: term(). -type column() :: pos_integer(). -type generated() :: boolean(). -type filename() :: file:filename_all(). --type line() :: integer(). +-type line() :: non_neg_integer(). -type location() :: line() | {line(), column()}. -type record() :: boolean(). -type text() :: string(). @@ -90,9 +94,13 @@ to_term(Anno) -> -ifdef(DEBUG). from_term(Term) when is_list(Term) -> Term; +from_term(Line) when is_integer(Line), Line < 0 -> % Before OTP 19 + set_generated(true, new(-Line)); from_term(Term) -> [{location, Term}]. -else. +from_term(Line) when is_integer(Line), Line < 0 -> % Before OTP 19 + set_generated(true, new(-Line)); from_term(Term) -> Term. -endif. @@ -198,18 +206,11 @@ file(Anno) -> Anno :: anno(). generated(Line) when ?ALINE(Line) -> - Line =< 0; + false; generated({Line, Column}) when ?ALINE(Line), ?ACOLUMN(Column) -> - Line =< 0; + false; generated(Anno) -> - _ = anno_info(Anno, generated, false), - {location, Location} = lists:keyfind(location, 1, Anno), - case Location of - {Line, _Column} -> - Line =< 0; - Line -> - Line =< 0 - end. + anno_info(Anno, generated, false). -spec line(Anno) -> line() when Anno :: anno(). @@ -226,18 +227,11 @@ line(Anno) -> Anno :: anno(). location(Line) when ?ALINE(Line) -> - abs(Line); -location({Line, Column}) when ?ALINE(Line), ?ACOLUMN(Column) -> - {abs(Line), Column}; + Line; +location({Line, Column}=Location) when ?ALINE(Line), ?ACOLUMN(Column) -> + Location; location(Anno) -> - case anno_info(Anno, location) of - Line when Line < 0 -> - -Line; - {Line, Column} when Line < 0 -> - {-Line, Column}; - Location -> - Location - end. + anno_info(Anno, location). -spec record(Anno) -> record() when Anno :: anno(). @@ -270,31 +264,8 @@ set_file(File, Anno) -> Generated :: generated(), Anno :: anno(). -set_generated(true, Line) when ?ALINE(Line) -> - -abs(Line); -set_generated(false, Line) when ?ALINE(Line) -> - abs(Line); -set_generated(true, {Line, Column}) when ?ALINE(Line), - ?ACOLUMN(Column) -> - {-abs(Line),Column}; -set_generated(false, {Line, Column}) when ?ALINE(Line), - ?ACOLUMN(Column) -> - {abs(Line),Column}; set_generated(Generated, Anno) -> - _ = set(generated, Generated, Anno), - {location, Location} = lists:keyfind(location, 1, Anno), - NewLocation = - case Location of - {Line, Column} when Generated -> - {-abs(Line), Column}; - {Line, Column} when not Generated -> - {abs(Line), Column}; - Line when Generated -> - -abs(Line); - Line when not Generated -> - abs(Line) - end, - lists:keyreplace(location, 1, Anno, {location, NewLocation}). + set(generated, Generated, Anno). -spec set_line(Line, Anno) -> Anno when Line :: line(), @@ -313,38 +284,17 @@ set_line(Line, Anno) -> Anno :: anno(). set_location(Line, L) when ?ALINE(L), ?LLINE(Line) -> - new_location(fix_line(Line, L)); + new_location(Line); set_location(Line, {L, Column}) when ?ALINE(L), ?ACOLUMN(Column), ?LLINE(Line) -> - new_location(fix_line(Line, L)); + new_location(Line); set_location({L, C}=Loc, Line) when ?ALINE(Line), ?LLINE(L), ?LCOLUMN(C) -> - new_location(fix_location(Loc, Line)); + new_location(Loc); set_location({L, C}=Loc, {Line, Column}) when ?ALINE(Line), ?ACOLUMN(Column), ?LLINE(L), ?LCOLUMN(C) -> - new_location(fix_location(Loc, Line)); + new_location(Loc); set_location(Location, Anno) -> - _ = set(location, Location, Anno), - {location, OldLocation} = lists:keyfind(location, 1, Anno), - NewLocation = - case {Location, OldLocation} of - {{_Line, _Column}=Loc, {L, _C}} -> - fix_location(Loc, L); - {Line, {L, _C}} -> - fix_line(Line, L); - {{_Line, _Column}=Loc, L} -> - fix_location(Loc, L); - {Line, L} -> - fix_line(Line, L) - end, - lists:keyreplace(location, 1, Anno, {location, NewLocation}). - -fix_location({Line, Column}, OldLine) -> - {fix_line(Line, OldLine), Column}. - -fix_line(Line, OldLine) when OldLine < 0, Line > 0 -> - -Line; -fix_line(Line, _OldLine) -> - Line. + set(location, Location, Anno). -spec set_record(Record, Anno) -> Anno when Record :: record(), @@ -383,7 +333,7 @@ set_anno(Item, Value, Anno) -> _ -> lists:keyreplace(Item, 1, Anno, {Item, Value}) end, - simplify(R) + reset_simplify(R) end. reset(Anno, Item) -> diff --git a/lib/stdlib/src/erl_bits.erl b/lib/stdlib/src/erl_bits.erl index ddcfcfdf02..5851401026 100644 --- a/lib/stdlib/src/erl_bits.erl +++ b/lib/stdlib/src/erl_bits.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1999-2009. All Rights Reserved. +%% Copyright Ericsson AB 1999-2016. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. diff --git a/lib/stdlib/src/erl_compile.erl b/lib/stdlib/src/erl_compile.erl index 5ca233cde7..18d7548fdc 100644 --- a/lib/stdlib/src/erl_compile.erl +++ b/lib/stdlib/src/erl_compile.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1997-2014. All Rights Reserved. +%% Copyright Ericsson AB 1997-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -60,6 +60,7 @@ compile_cmdline() -> _ -> my_halt(2) end. +-spec my_halt(_) -> no_return(). my_halt(Reason) -> erlang:halt(Reason). @@ -180,7 +181,7 @@ parse_generic_option("P", T, #options{specific=Spec}=Opts) -> parse_generic_option("S", T, #options{specific=Spec}=Opts) -> compile1(T, Opts#options{specific=['S'|Spec]}); parse_generic_option(Option, _T, _Opts) -> - io:format(?STDERR, "Unknown option: -~s\n", [Option]), + io:format(?STDERR, "Unknown option: -~ts\n", [Option]), usage(). parse_dep_option("", T) -> @@ -201,7 +202,7 @@ parse_dep_option("T"++Opt, T0) -> {Target,T} = get_option("MT", Opt, T0), {[{makedep_target,Target}],T}; parse_dep_option(Opt, _T) -> - io:format(?STDERR, "Unknown option: -M~s\n", [Opt]), + io:format(?STDERR, "Unknown option: -M~ts\n", [Opt]), usage(). usage() -> @@ -336,7 +337,7 @@ file_or_directory(Name) -> make_term(Str) -> case erl_scan:string(Str) of {ok, Tokens, _} -> - case erl_parse:parse_term(Tokens ++ [{dot, 1}]) of + case erl_parse:parse_term(Tokens ++ [{dot, erl_anno:new(1)}]) of {ok, Term} -> Term; {error, {_,_,Reason}} -> io:format(?STDERR, "~ts: ~ts~n", [Reason, Str]), diff --git a/lib/stdlib/src/erl_eval.erl b/lib/stdlib/src/erl_eval.erl index ca3cc43b19..eafee346eb 100644 --- a/lib/stdlib/src/erl_eval.erl +++ b/lib/stdlib/src/erl_eval.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2015. All Rights Reserved. +%% Copyright Ericsson AB 1996-2016. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -415,7 +415,7 @@ expr({call,_,{atom,_,Func},As0}, Bs0, Lf, Ef, RBs) -> {As,Bs} = expr_list(As0, Bs0, Lf, Ef), bif(Func, As, Bs, Ef, RBs); false -> - local_func(Func, As0, Bs0, Lf, RBs) + local_func(Func, As0, Bs0, Lf, Ef, RBs) end; expr({call,_,Func0,As0}, Bs0, Lf, Ef, RBs) -> % function or {Mod,Fun} {value,Func,Bs1} = expr(Func0, Bs0, Lf, Ef, none), @@ -542,33 +542,34 @@ unhide_calls([E | Es], MaxLine, D) -> unhide_calls(E, _MaxLine, _D) -> E. -%% local_func(Function, Arguments, Bindings, LocalFuncHandler, RBs) -> +%% local_func(Function, Arguments, Bindings, LocalFuncHandler, +%% ExternalFuncHandler, RBs) -> %% {value,Value,Bindings} | Value when %% LocalFuncHandler = {value,F} | {value,F,Eas} | %% {eval,F} | {eval,F,Eas} | none. -local_func(Func, As0, Bs0, {value,F}, value) -> - {As1,_Bs1} = expr_list(As0, Bs0, {value,F}), +local_func(Func, As0, Bs0, {value,F}, Ef, value) -> + {As1,_Bs1} = expr_list(As0, Bs0, {value,F}, Ef), %% Make tail recursive calls when possible. F(Func, As1); -local_func(Func, As0, Bs0, {value,F}, RBs) -> - {As1,Bs1} = expr_list(As0, Bs0, {value,F}), +local_func(Func, As0, Bs0, {value,F}, Ef, RBs) -> + {As1,Bs1} = expr_list(As0, Bs0, {value,F}, Ef), ret_expr(F(Func, As1), Bs1, RBs); -local_func(Func, As0, Bs0, {value,F,Eas}, RBs) -> +local_func(Func, As0, Bs0, {value,F,Eas}, Ef, RBs) -> Fun = fun(Name, Args) -> apply(F, [Name,Args|Eas]) end, - local_func(Func, As0, Bs0, {value, Fun}, RBs); -local_func(Func, As, Bs, {eval,F}, RBs) -> + local_func(Func, As0, Bs0, {value, Fun}, Ef, RBs); +local_func(Func, As, Bs, {eval,F}, _Ef, RBs) -> local_func2(F(Func, As, Bs), RBs); -local_func(Func, As, Bs, {eval,F,Eas}, RBs) -> +local_func(Func, As, Bs, {eval,F,Eas}, _Ef, RBs) -> local_func2(apply(F, [Func,As,Bs|Eas]), RBs); %% These two clauses are for backwards compatibility. -local_func(Func, As0, Bs0, {M,F}, RBs) -> - {As1,Bs1} = expr_list(As0, Bs0, {M,F}), +local_func(Func, As0, Bs0, {M,F}, Ef, RBs) -> + {As1,Bs1} = expr_list(As0, Bs0, {M,F}, Ef), ret_expr(M:F(Func,As1), Bs1, RBs); -local_func(Func, As, _Bs, {M,F,Eas}, RBs) -> +local_func(Func, As, _Bs, {M,F,Eas}, _Ef, RBs) -> local_func2(apply(M, F, [Func,As|Eas]), RBs); %% Default unknown function handler to undefined function. -local_func(Func, As0, _Bs0, none, _RBs) -> +local_func(Func, As0, _Bs0, none, _Ef, _RBs) -> erlang:raise(error, undef, [{erl_eval,Func,length(As0)}|stacktrace()]). local_func2({value,V,Bs}, RBs) -> @@ -1184,7 +1185,7 @@ match_tuple([], _, _, Bs, _BBs) -> match_map([{map_field_exact, _, K, V}|Fs], Map, Bs0, BBs) -> Vm = try - {value, Ke, _} = expr(K, Bs0), + {value, Ke, _} = expr(K, BBs), maps:get(Ke,Map) catch error:_ -> throw(nomatch) @@ -1305,6 +1306,7 @@ partial_eval(Expr) -> ev_expr({op,_,Op,L,R}) -> erlang:Op(ev_expr(L), ev_expr(R)); ev_expr({op,_,Op,A}) -> erlang:Op(ev_expr(A)); ev_expr({integer,_,X}) -> X; +ev_expr({char,_,X}) -> X; ev_expr({float,_,X}) -> X; ev_expr({atom,_,X}) -> X; ev_expr({tuple,_,Es}) -> diff --git a/lib/stdlib/src/erl_expand_records.erl b/lib/stdlib/src/erl_expand_records.erl index bcfeef7321..d7bd15d9db 100644 --- a/lib/stdlib/src/erl_expand_records.erl +++ b/lib/stdlib/src/erl_expand_records.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2005-2015. All Rights Reserved. +%% Copyright Ericsson AB 2005-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -17,7 +17,8 @@ %% %% %CopyrightEnd% %% -%% Purpose : Expand records into tuples. +%% Purpose: Expand records into tuples. Also add explicit module +%% names to calls to imported functions and BIFs. %% N.B. Although structs (tagged tuples) are not yet allowed in the %% language there is code included in pattern/2 and expr/3 (commented out) @@ -29,67 +30,51 @@ -import(lists, [map/2,foldl/3,foldr/3,sort/1,reverse/1,duplicate/2]). --record(exprec, {compile=[], % Compile flags - vcount=0, % Variable counter - imports=[], % Imports - records=dict:new(), % Record definitions - trecords=sets:new(), % Typed records - uses_types=false, % Are there -spec or -type in the module - strict_ra=[], % strict record accesses - checked_ra=[] % successfully accessed records - }). - --spec(module(AbsForms, CompileOptions) -> AbsForms when +-record(exprec, {compile=[], % Compile flags + vcount=0, % Variable counter + calltype=#{}, % Call types + records=#{}, % Record definitions + strict_ra=[], % strict record accesses + checked_ra=[] % successfully accessed records + }). + +-spec(module(AbsForms, CompileOptions) -> AbsForms2 when AbsForms :: [erl_parse:abstract_form()], + AbsForms2 :: [erl_parse:abstract_form()], CompileOptions :: [compile:option()]). %% Is is assumed that Fs is a valid list of forms. It should pass %% erl_lint without errors. module(Fs0, Opts0) -> Opts = compiler_options(Fs0) ++ Opts0, - TRecs = typed_records(Fs0), - UsesTypes = uses_types(Fs0), - St0 = #exprec{compile = Opts, trecords = TRecs, uses_types = UsesTypes}, + Calltype = init_calltype(Fs0), + St0 = #exprec{compile = Opts, calltype = Calltype}, {Fs,_St} = forms(Fs0, St0), Fs. compiler_options(Forms) -> lists:flatten([C || {attribute,_,compile,C} <- Forms]). -typed_records(Fs) -> - typed_records(Fs, sets:new()). - -typed_records([{attribute,_L,type,{{record, Name},_Defs,[]}} | Fs], Trecs) -> - typed_records(Fs, sets:add_element(Name, Trecs)); -typed_records([_|Fs], Trecs) -> - typed_records(Fs, Trecs); -typed_records([], Trecs) -> - Trecs. - -uses_types([{attribute,_L,spec,_}|_]) -> true; -uses_types([{attribute,_L,type,_}|_]) -> true; -uses_types([{attribute,_L,opaque,_}|_]) -> true; -uses_types([_|Fs]) -> uses_types(Fs); -uses_types([]) -> false. - -forms([{attribute,L,record,{Name,Defs}} | Fs], St0) -> +init_calltype(Forms) -> + Locals = [{{Name,Arity},local} || {function,_,Name,Arity,_} <- Forms], + Ctype = maps:from_list(Locals), + init_calltype_imports(Forms, Ctype). + +init_calltype_imports([{attribute,_,import,{Mod,Fs}}|T], Ctype0) -> + true = is_atom(Mod), + Ctype = foldl(fun(FA, Acc) -> + Acc#{FA=>{imported,Mod}} + end, Ctype0, Fs), + init_calltype_imports(T, Ctype); +init_calltype_imports([_|T], Ctype) -> + init_calltype_imports(T, Ctype); +init_calltype_imports([], Ctype) -> Ctype. + +forms([{attribute,_,record,{Name,Defs}}=Attr | Fs], St0) -> NDefs = normalise_fields(Defs), - St = St0#exprec{records=dict:store(Name, NDefs, St0#exprec.records)}, + St = St0#exprec{records=maps:put(Name, NDefs, St0#exprec.records)}, {Fs1, St1} = forms(Fs, St), - %% Check if we need to keep the record information for usage in types. - case St#exprec.uses_types of - true -> - case sets:is_element(Name, St#exprec.trecords) of - true -> {Fs1, St1}; - false -> {[{attribute,L,type,{{record,Name},Defs,[]}}|Fs1], St1} - end; - false -> - {Fs1, St1} - end; -forms([{attribute,L,import,Is} | Fs0], St0) -> - St1 = import(Is, St0), - {Fs,St2} = forms(Fs0, St1), - {[{attribute,L,import,Is} | Fs], St2}; + {[Attr | Fs1], St1}; forms([{function,L,N,A,Cs0} | Fs0], St0) -> {Cs,St1} = clauses(Cs0, St0), {Fs,St2} = forms(Fs0, St1), @@ -362,8 +347,16 @@ expr({'receive',Line,Cs0,To0,ToEs0}, St0) -> {ToEs,St2} = exprs(ToEs0, St1), {Cs,St3} = clauses(Cs0, St2), {{'receive',Line,Cs,To,ToEs},St3}; -expr({'fun',_,{function,_F,_A}}=Fun, St) -> - {Fun,St}; +expr({'fun',Lf,{function,F,A}}=Fun0, St0) -> + case erl_internal:bif(F, A) of + true -> + {As,St1} = new_vars(A, Lf, St0), + Cs = [{clause,Lf,As,[],[{call,Lf,{atom,Lf,F},As}]}], + Fun = {'fun',Lf,{clauses,Cs}}, + expr(Fun, St1); + false -> + {Fun0,St0} + end; expr({'fun',_,{function,_M,_F,_A}}=Fun, St) -> {Fun,St}; expr({'fun',Line,{clauses,Cs0}}, St0) -> @@ -380,14 +373,30 @@ expr({call,Line,{remote,_,{atom,_,erlang},{atom,_,is_record}}, expr({call,Line,{tuple,_,[{atom,_,erlang},{atom,_,is_record}]}, [A,{atom,_,Name}]}, St) -> record_test(Line, A, Name, St); +expr({call,Line,{atom,_La,record_info},[_,_]=As0}, St0) -> + {As,St1} = expr_list(As0, St0), + record_info_call(Line, As, St1); expr({call,Line,{atom,_La,N}=Atom,As0}, St0) -> {As,St1} = expr_list(As0, St0), Ar = length(As), - case {N,Ar} =:= {record_info,2} andalso not imported(N, Ar, St1) of - true -> - record_info_call(Line, As, St1); - false -> - {{call,Line,Atom,As},St1} + NA = {N,Ar}, + case St0#exprec.calltype of + #{NA := local} -> + {{call,Line,Atom,As},St1}; + #{NA := {imported,Module}} -> + ModAtom = {atom,Line,Module}, + {{call,Line,{remote,Line,ModAtom,Atom},As},St1}; + _ -> + case erl_internal:bif(N, Ar) of + true -> + ModAtom = {atom,Line,erlang}, + {{call,Line,{remote,Line,ModAtom,Atom},As},St1}; + false -> + %% Call to a module_info/0,1 or one of the + %% pseudo-functions in the shell. Leave it as + %% a local call. + {{call,Line,Atom,As},St1} + end end; expr({call,Line,{remote,Lr,M,F},As0}, St0) -> {[M1,F1 | As1],St1} = expr_list([M,F | As0], St0), @@ -498,9 +507,16 @@ lc_tq(Line, [{b_generate,Lg,P0,G0} | Qs0], St0) -> {P1,St2} = pattern(P0, St1), {Qs1,St3} = lc_tq(Line, Qs0, St2), {[{b_generate,Lg,P1,G1} | Qs1],St3}; -lc_tq(Line, [F0 | Qs0], St0) -> +lc_tq(Line, [F0 | Qs0], #exprec{calltype=Calltype}=St0) -> %% Allow record/2 and expand out as guard test. - case erl_lint:is_guard_test(F0) of + IsOverriden = fun(FA) -> + case Calltype of + #{FA := local} -> true; + #{FA := {imported,_}} -> true; + _ -> false + end + end, + case erl_lint:is_guard_test(F0, [], IsOverriden) of true -> {F1,St1} = guard_test(F0, St0), {Qs1,St2} = lc_tq(Line, Qs0, St1), @@ -513,7 +529,6 @@ lc_tq(Line, [F0 | Qs0], St0) -> lc_tq(_Line, [], St0) -> {[],St0#exprec{checked_ra = []}}. - %% normalise_fields([RecDef]) -> [Field]. %% Normalise the field definitions to always have a default value. If %% none has been given then use 'undefined'. @@ -531,7 +546,7 @@ normalise_fields(Fs) -> %% record_fields(RecordName, State) %% find_field(FieldName, Fields) -record_fields(R, St) -> dict:fetch(R, St#exprec.records). +record_fields(R, St) -> maps:get(R, St#exprec.records). find_field(F, [{record_field,_,{atom,_,F},Val} | _]) -> {ok,Val}; find_field(F, [_ | Fs]) -> find_field(F, Fs); @@ -798,6 +813,13 @@ bin_element({bin_element,Line,Expr,Size,Type}, {Es,St0}) -> end, {[{bin_element,Line,Expr1,Size1,Type} | Es],St2}. +new_vars(N, L, St) -> new_vars(N, L, St, []). + +new_vars(N, L, St0, Vs) when N > 0 -> + {V,St1} = new_var(L, St0), + new_vars(N-1, L, St1, [V|Vs]); +new_vars(0, _L, St, Vs) -> {Vs,St}. + new_var(L, St0) -> {New,St1} = new_var_name(St0), {{var,L,New},St1}. @@ -812,18 +834,6 @@ make_list(Ts, Line) -> call_error(L, R) -> {call,L,{remote,L,{atom,L,erlang},{atom,L,error}},[R]}. -import({Mod,Fs}, St) -> - St#exprec{imports=add_imports(Mod, Fs, St#exprec.imports)}; -import(_Mod0, St) -> - St. - -add_imports(Mod, [F | Fs], Is) -> - add_imports(Mod, Fs, orddict:store(F, Mod, Is)); -add_imports(_, [], Is) -> Is. - -imported(F, A, St) -> - orddict:is_key({F,A}, St#exprec.imports). - %%% %%% Replace is_record/3 in guards with matching if possible. %%% diff --git a/lib/stdlib/src/erl_internal.erl b/lib/stdlib/src/erl_internal.erl index f7711d0ad7..89b97b901e 100644 --- a/lib/stdlib/src/erl_internal.erl +++ b/lib/stdlib/src/erl_internal.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1998-2014. All Rights Reserved. +%% Copyright Ericsson AB 1998-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -54,6 +54,8 @@ -export([is_type/2]). +-export([add_predefined_functions/1]). + %%--------------------------------------------------------------------------- %% Erlang builtin functions allowed in guards. @@ -61,42 +63,28 @@ Name :: atom(), Arity :: arity(). +%% Please keep the alphabetical order. guard_bif(abs, 1) -> true; -guard_bif(float, 1) -> true; -guard_bif(trunc, 1) -> true; -guard_bif(round, 1) -> true; -guard_bif(length, 1) -> true; -guard_bif(hd, 1) -> true; -guard_bif(tl, 1) -> true; -guard_bif(size, 1) -> true; +guard_bif(binary_part, 2) -> true; +guard_bif(binary_part, 3) -> true; guard_bif(bit_size, 1) -> true; guard_bif(byte_size, 1) -> true; +guard_bif(ceil, 1) -> true; guard_bif(element, 2) -> true; -guard_bif(self, 0) -> true; +guard_bif(float, 1) -> true; +guard_bif(floor, 1) -> true; +guard_bif(hd, 1) -> true; +guard_bif(length, 1) -> true; guard_bif(map_size, 1) -> true; guard_bif(node, 0) -> true; guard_bif(node, 1) -> true; +guard_bif(round, 1) -> true; +guard_bif(self, 0) -> true; +guard_bif(size, 1) -> true; +guard_bif(tl, 1) -> true; +guard_bif(trunc, 1) -> true; guard_bif(tuple_size, 1) -> true; -guard_bif(is_atom, 1) -> true; -guard_bif(is_binary, 1) -> true; -guard_bif(is_bitstring, 1) -> true; -guard_bif(is_boolean, 1) -> true; -guard_bif(is_float, 1) -> true; -guard_bif(is_function, 1) -> true; -guard_bif(is_function, 2) -> true; -guard_bif(is_integer, 1) -> true; -guard_bif(is_list, 1) -> true; -guard_bif(is_map, 1) -> true; -guard_bif(is_number, 1) -> true; -guard_bif(is_pid, 1) -> true; -guard_bif(is_port, 1) -> true; -guard_bif(is_reference, 1) -> true; -guard_bif(is_tuple, 1) -> true; -guard_bif(is_record, 2) -> true; -guard_bif(is_record, 3) -> true; -guard_bif(binary_part, 2) -> true; -guard_bif(binary_part, 3) -> true; -guard_bif(Name, A) when is_atom(Name), is_integer(A) -> false. +guard_bif(Name, A) -> new_type_test(Name, A). %% Erlang type tests. -spec type_test(Name, Arity) -> boolean() when @@ -109,10 +97,11 @@ type_test(Name, Arity) -> %% Erlang new-style type tests. -spec new_type_test(Name::atom(), Arity::arity()) -> boolean(). +%% Please keep the alphabetical order. new_type_test(is_atom, 1) -> true; -new_type_test(is_boolean, 1) -> true; new_type_test(is_binary, 1) -> true; new_type_test(is_bitstring, 1) -> true; +new_type_test(is_boolean, 1) -> true; new_type_test(is_float, 1) -> true; new_type_test(is_function, 1) -> true; new_type_test(is_function, 2) -> true; @@ -122,10 +111,10 @@ new_type_test(is_map, 1) -> true; new_type_test(is_number, 1) -> true; new_type_test(is_pid, 1) -> true; new_type_test(is_port, 1) -> true; -new_type_test(is_reference, 1) -> true; -new_type_test(is_tuple, 1) -> true; new_type_test(is_record, 2) -> true; new_type_test(is_record, 3) -> true; +new_type_test(is_reference, 1) -> true; +new_type_test(is_tuple, 1) -> true; new_type_test(Name, A) when is_atom(Name), is_integer(A) -> false. %% Erlang old-style type tests. @@ -271,6 +260,7 @@ bif(bitsize, 1) -> true; bif(bit_size, 1) -> true; bif(bitstring_to_list, 1) -> true; bif(byte_size, 1) -> true; +bif(ceil, 1) -> true; bif(check_old_code, 1) -> true; bif(check_process_code, 2) -> true; bif(check_process_code, 3) -> true; @@ -291,6 +281,7 @@ bif(float_to_list, 1) -> true; bif(float_to_list, 2) -> true; bif(float_to_binary, 1) -> true; bif(float_to_binary, 2) -> true; +bif(floor, 1) -> true; bif(garbage_collect, 0) -> true; bif(garbage_collect, 1) -> true; bif(garbage_collect, 2) -> true; @@ -340,6 +331,8 @@ bif(list_to_float, 1) -> true; bif(list_to_integer, 1) -> true; bif(list_to_integer, 2) -> true; bif(list_to_pid, 1) -> true; +bif(list_to_port, 1) -> true; +bif(list_to_ref, 1) -> true; bif(list_to_tuple, 1) -> true; bif(load_module, 2) -> true; bif(make_ref, 0) -> true; @@ -357,6 +350,7 @@ bif(nodes, 1) -> true; bif(now, 0) -> true; bif(open_port, 2) -> true; bif(pid_to_list, 1) -> true; +bif(port_to_list, 1) -> true; bif(port_close, 1) -> true; bif(port_command, 2) -> true; bif(port_command, 3) -> true; @@ -370,6 +364,7 @@ bif(process_info, 2) -> true; bif(processes, 0) -> true; bif(purge_module, 1) -> true; bif(put, 2) -> true; +bif(ref_to_list, 1) -> true; bif(register, 2) -> true; bif(registered, 0) -> true; bif(round, 1) -> true; @@ -584,3 +579,68 @@ is_type(term, 0) -> true; is_type(timeout, 0) -> true; is_type(tuple, 0) -> true; is_type(_, _) -> false. + +%%% +%%% Add and export the pre-defined functions: +%%% +%%% module_info/0 +%%% module_info/1 +%%% behaviour_info/1 (optional) +%%% + +-spec add_predefined_functions(Forms) -> UpdatedForms when + Forms :: [erl_parse:abstract_form() | erl_parse:form_info()], + UpdatedForms :: [erl_parse:abstract_form() | erl_parse:form_info()]. + +add_predefined_functions(Forms) -> + Forms ++ predefined_functions(Forms). + +predefined_functions(Forms) -> + Attrs = [{Name,Val} || {attribute,_,Name,Val} <- Forms], + {module,Mod} = lists:keyfind(module, 1, Attrs), + Callbacks = [Callback || {callback,Callback} <- Attrs], + OptionalCallbacks = get_optional_callbacks(Attrs), + Mpf1 = module_predef_func_beh_info(Callbacks, OptionalCallbacks), + Mpf2 = module_predef_funcs_mod_info(Mod), + Mpf = [erl_parse:new_anno(F) || F <- Mpf1++Mpf2], + Exp = [{F,A} || {function,_,F,A,_} <- Mpf], + [{attribute,0,export,Exp}|Mpf]. + +get_optional_callbacks(Attrs) -> + L = [O || {optional_callbacks,O} <- Attrs, is_fa_list(O)], + lists:append(L). + +is_fa_list([{FuncName, Arity}|L]) + when is_atom(FuncName), is_integer(Arity), Arity >= 0 -> + is_fa_list(L); +is_fa_list([]) -> true; +is_fa_list(_) -> false. + +module_predef_func_beh_info([], _) -> + []; +module_predef_func_beh_info(Callbacks0, OptionalCallbacks) -> + Callbacks = [FA || {{_,_}=FA,_} <- Callbacks0], + List = make_list(Callbacks), + OptionalList = make_list(OptionalCallbacks), + [{function,0,behaviour_info,1, + [{clause,0,[{atom,0,callbacks}],[],[List]}, + {clause,0,[{atom,0,optional_callbacks}],[],[OptionalList]}]}]. + +make_list([]) -> {nil,0}; +make_list([{Name,Arity}|Rest]) -> + {cons,0, + {tuple,0, + [{atom,0,Name}, + {integer,0,Arity}]}, + make_list(Rest)}. + +module_predef_funcs_mod_info(Mod) -> + ModAtom = {atom,0,Mod}, + [{function,0,module_info,0, + [{clause,0,[],[], + [{call,0,{remote,0,{atom,0,erlang},{atom,0,get_module_info}}, + [ModAtom]}]}]}, + {function,0,module_info,1, + [{clause,0,[{var,0,'X'}],[], + [{call,0,{remote,0,{atom,0,erlang},{atom,0,get_module_info}}, + [ModAtom,{var,0,'X'}]}]}]}]. diff --git a/lib/stdlib/src/erl_lint.erl b/lib/stdlib/src/erl_lint.erl index c4cb5fdc80..9cd4727dc3 100644 --- a/lib/stdlib/src/erl_lint.erl +++ b/lib/stdlib/src/erl_lint.erl @@ -2,7 +2,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2015. All Rights Reserved. +%% Copyright Ericsson AB 1996-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -27,16 +27,12 @@ -export([module/1,module/2,module/3,format_error/1]). -export([exprs/2,exprs_opt/3,used_vars/2]). % Used from erl_eval.erl. --export([is_pattern_expr/1,is_guard_test/1,is_guard_test/2]). +-export([is_pattern_expr/1,is_guard_test/1,is_guard_test/2,is_guard_test/3]). -export([is_guard_expr/1]). -export([bool_option/4,value_option/3,value_option/7]). --export([modify_line/2]). - -import(lists, [member/2,map/2,foldl/3,foldr/3,mapfoldl/3,all/2,reverse/1]). --deprecated([{modify_line, 2, next_major_release}]). - %% bool_option(OnOpt, OffOpt, Default, Options) -> boolean(). %% value_option(Flag, Default, Options) -> Value. %% value_option(Flag, Default, OnOpt, OnVal, OffOpt, OffVal, Options) -> @@ -79,7 +75,7 @@ value_option(Flag, Default, On, OnVal, Off, OffVal, Opts) -> %%-define(DEBUGF(X,Y), io:format(X, Y)). -define(DEBUGF(X,Y), void). --type line() :: erl_anno:line(). % a convenient alias +-type line() :: erl_anno:anno(). % a convenient alias -type fa() :: {atom(), arity()}. % function+arity -type ta() :: {atom(), arity()}. % type+arity @@ -96,14 +92,22 @@ value_option(Flag, Default, On, OnVal, Off, OffVal, Opts) -> :: dict:dict(ta(), line()) }). + +%% Are we outside or inside a catch or try/catch? +-type catch_scope() :: 'none' + | 'after_old_catch' + | 'after_try' + | 'wrong_part_of_try' + | 'try_catch'. + %% Define the lint state record. %% 'called' and 'exports' contain {Line, {Function, Arity}}, %% the other function collections contain {Function, Arity}. -record(lint, {state=start :: 'start' | 'attribute' | 'function', - module=[], %Module + module='', %Module behaviour=[], %Behaviour exports=gb_sets:empty() :: gb_sets:set(fa()),%Exports - imports=[] :: [fa()], %Imports, an orddict() + imports=[] :: orddict:orddict(fa(), module()),%Imports compile=[], %Compile flags records=dict:new() %Record definitions :: dict:dict(atom(), {line(),Fields :: term()}), @@ -139,7 +143,9 @@ value_option(Flag, Default, On, OnVal, Off, OffVal, Opts) -> types = dict:new() %Type definitions :: dict:dict(ta(), #typeinfo{}), exp_types=gb_sets:empty() %Exported types - :: gb_sets:set(ta()) + :: gb_sets:set(ta()), + catch_scope = none %Inside/outside try or catch + :: catch_scope() }). -type lint_state() :: #lint{}. @@ -160,6 +166,8 @@ format_error(pmod_unsupported) -> "parameterized modules are no longer supported"; %% format_error({redefine_mod_import, M, P}) -> %% io_lib:format("module '~s' already imported from package '~s'", [M, P]); +format_error(non_latin1_module_unsupported) -> + "module names with non-latin1 characters are not supported"; format_error(invalid_call) -> "invalid function call"; @@ -167,49 +175,48 @@ format_error(invalid_record) -> "invalid record expression"; format_error({attribute,A}) -> - io_lib:format("attribute '~w' after function definitions", [A]); + io_lib:format("attribute ~tw after function definitions", [A]); format_error({missing_qlc_hrl,A}) -> io_lib:format("qlc:q/~w called, but \"qlc.hrl\" not included", [A]); format_error({redefine_import,{{F,A},M}}) -> - io_lib:format("function ~w/~w already imported from ~w", [F,A,M]); + io_lib:format("function ~tw/~w already imported from ~w", [F,A,M]); format_error({bad_inline,{F,A}}) -> - io_lib:format("inlined function ~w/~w undefined", [F,A]); + io_lib:format("inlined function ~tw/~w undefined", [F,A]); format_error({invalid_deprecated,D}) -> - io_lib:format("badly formed deprecated attribute ~w", [D]); + io_lib:format("badly formed deprecated attribute ~tw", [D]); format_error({bad_deprecated,{F,A}}) -> - io_lib:format("deprecated function ~w/~w undefined or not exported", [F,A]); + io_lib:format("deprecated function ~tw/~w undefined or not exported", + [F,A]); format_error({bad_nowarn_unused_function,{F,A}}) -> - io_lib:format("function ~w/~w undefined", [F,A]); + io_lib:format("function ~tw/~w undefined", [F,A]); format_error({bad_nowarn_bif_clash,{F,A}}) -> - io_lib:format("function ~w/~w undefined", [F,A]); + io_lib:format("function ~tw/~w undefined", [F,A]); format_error(disallowed_nowarn_bif_clash) -> io_lib:format("compile directive nowarn_bif_clash is no longer allowed,~n" " - use explicit module names or -compile({no_auto_import, [F/A]})", []); -format_error({bad_nowarn_deprecated_function,{M,F,A}}) -> - io_lib:format("~w:~w/~w is not a deprecated function", [M,F,A]); format_error({bad_on_load,Term}) -> - io_lib:format("badly formed on_load attribute: ~w", [Term]); + io_lib:format("badly formed on_load attribute: ~tw", [Term]); format_error(multiple_on_loads) -> "more than one on_load attribute"; format_error({bad_on_load_arity,{F,A}}) -> - io_lib:format("function ~w/~w has wrong arity (must be 0)", [F,A]); + io_lib:format("function ~tw/~w has wrong arity (must be 0)", [F,A]); format_error({undefined_on_load,{F,A}}) -> - io_lib:format("function ~w/~w undefined", [F,A]); + io_lib:format("function ~tw/~w undefined", [F,A]); format_error(export_all) -> "export_all flag enabled - all functions will be exported"; format_error({duplicated_export, {F,A}}) -> - io_lib:format("function ~w/~w already exported", [F,A]); + io_lib:format("function ~tw/~w already exported", [F,A]); format_error({unused_import,{{F,A},M}}) -> - io_lib:format("import ~w:~w/~w is unused", [M,F,A]); + io_lib:format("import ~w:~tw/~w is unused", [M,F,A]); format_error({undefined_function,{F,A}}) -> - io_lib:format("function ~w/~w undefined", [F,A]); + io_lib:format("function ~tw/~w undefined", [F,A]); format_error({redefine_function,{F,A}}) -> - io_lib:format("function ~w/~w already defined", [F,A]); + io_lib:format("function ~tw/~w already defined", [F,A]); format_error({define_import,{F,A}}) -> - io_lib:format("defining imported function ~w/~w", [F,A]); + io_lib:format("defining imported function ~tw/~w", [F,A]); format_error({unused_function,{F,A}}) -> - io_lib:format("function ~w/~w is unused", [F,A]); + io_lib:format("function ~tw/~w is unused", [F,A]); format_error({call_to_redefined_bif,{F,A}}) -> io_lib:format("ambiguous call of overridden auto-imported BIF ~w/~w~n" " - use erlang:~w/~w or \"-compile({no_auto_import,[~w/~w]}).\" " @@ -225,7 +232,15 @@ format_error({redefine_old_bif_import,{F,A}}) -> format_error({redefine_bif_import,{F,A}}) -> io_lib:format("import directive overrides auto-imported BIF ~w/~w~n" " - use \"-compile({no_auto_import,[~w/~w]}).\" to resolve name clash", [F,A,F,A]); - +format_error({get_stacktrace,wrong_part_of_try}) -> + "erlang:get_stacktrace/0 used in the wrong part of 'try' expression. " + "(Use it in the block between 'catch' and 'end'.)"; +format_error({get_stacktrace,after_old_catch}) -> + "erlang:get_stacktrace/0 used following an old-style 'catch' " + "may stop working in a future release. (Use it inside 'try'.)"; +format_error({get_stacktrace,after_try}) -> + "erlang:get_stacktrace/0 used following a 'try' expression " + "may stop working in a future release. (Use it inside 'try'.)"; format_error({deprecated, MFA, ReplacementMFA, Rel}) -> io_lib:format("~s is deprecated and will be removed in ~s; use ~s", [format_mfa(MFA), Rel, format_mfa(ReplacementMFA)]); @@ -238,8 +253,15 @@ format_error({removed, MFA, ReplacementMFA, Rel}) -> "use ~s", [format_mfa(MFA), Rel, format_mfa(ReplacementMFA)]); format_error({removed, MFA, String}) when is_list(String) -> io_lib:format("~s: ~s", [format_mfa(MFA), String]); +format_error({removed_type, MNA, ReplacementMNA, Rel}) -> + io_lib:format("the type ~s was removed in ~s; use ~s instead", + [format_mna(MNA), Rel, format_mna(ReplacementMNA)]); format_error({obsolete_guard, {F, A}}) -> - io_lib:format("~p/~p obsolete", [F, A]); + io_lib:format("~p/~p obsolete (use is_~p/~p)", [F, A, F, A]); +format_error({obsolete_guard_overridden,Test}) -> + io_lib:format("obsolete ~s/1 (meaning is_~s/1) is illegal when " + "there is a local/imported function named is_~p/1 ", + [Test,Test,Test]); format_error({too_many_arguments,Arity}) -> io_lib:format("too many arguments (~w) - " "maximum allowed is ~w", [Arity,?MAX_ARGUMENTS]); @@ -250,7 +272,7 @@ format_error(illegal_bin_pattern) -> "binary patterns cannot be matched in parallel using '='"; format_error(illegal_expr) -> "illegal expression"; format_error({illegal_guard_local_call, {F,A}}) -> - io_lib:format("call to local/imported function ~w/~w is illegal in guard", + io_lib:format("call to local/imported function ~tw/~w is illegal in guard", [F,A]); format_error(illegal_guard_expr) -> "illegal guard expression"; %% --- maps --- @@ -258,23 +280,23 @@ format_error(illegal_map_construction) -> "only association operators '=>' are allowed in map construction"; %% --- records --- format_error({undefined_record,T}) -> - io_lib:format("record ~w undefined", [T]); + io_lib:format("record ~tw undefined", [T]); format_error({redefine_record,T}) -> - io_lib:format("record ~w already defined", [T]); + io_lib:format("record ~tw already defined", [T]); format_error({redefine_field,T,F}) -> - io_lib:format("field ~w already defined in record ~w", [F,T]); + io_lib:format("field ~tw already defined in record ~tw", [F,T]); format_error({undefined_field,T,F}) -> - io_lib:format("field ~w undefined in record ~w", [F,T]); + io_lib:format("field ~tw undefined in record ~tw", [F,T]); format_error(illegal_record_info) -> "illegal record info"; format_error({field_name_is_variable,T,F}) -> - io_lib:format("field ~w is not an atom or _ in record ~w", [F,T]); + io_lib:format("field ~tw is not an atom or _ in record ~tw", [F,T]); format_error({wildcard_in_update,T}) -> - io_lib:format("meaningless use of _ in update of record ~w", [T]); + io_lib:format("meaningless use of _ in update of record ~tw", [T]); format_error({unused_record,T}) -> - io_lib:format("record ~w is unused", [T]); + io_lib:format("record ~tw is unused", [T]); format_error({untyped_record,T}) -> - io_lib:format("record ~w has field(s) without type information", [T]); + io_lib:format("record ~tw has field(s) without type information", [T]); %% --- variables ---- format_error({unbound_var,V}) -> io_lib:format("variable ~w is unbound", [V]); @@ -292,7 +314,10 @@ format_error({variable_in_record_def,V}) -> io_lib:format("variable ~w in record definition", [V]); %% --- binaries --- format_error({undefined_bittype,Type}) -> - io_lib:format("bit type ~w undefined", [Type]); + io_lib:format("bit type ~tw undefined", [Type]); +format_error({bittype_mismatch,Val1,Val2,What}) -> + io_lib:format("conflict in ~s specification for bit field: '~p' and '~p'", + [What,Val1,Val2]); format_error(bittype_unit) -> "a bit unit size must not be specified unless a size is specified too"; format_error(illegal_bitsize) -> @@ -309,13 +334,13 @@ format_error(unsized_binary_in_bin_gen_pattern) -> "binary fields without size are not allowed in patterns of bit string generators"; %% --- behaviours --- format_error({conflicting_behaviours,{Name,Arity},B,FirstL,FirstB}) -> - io_lib:format("conflicting behaviours - callback ~w/~w required by both '~p' " + io_lib:format("conflicting behaviours - callback ~tw/~w required by both '~p' " "and '~p' ~s", [Name,Arity,B,FirstB,format_where(FirstL)]); format_error({undefined_behaviour_func, {Func,Arity}, Behaviour}) -> - io_lib:format("undefined callback function ~w/~w (behaviour '~w')", + io_lib:format("undefined callback function ~tw/~w (behaviour '~w')", [Func,Arity,Behaviour]); format_error({undefined_behaviour,Behaviour}) -> - io_lib:format("behaviour ~w undefined", [Behaviour]); + io_lib:format("behaviour ~tw undefined", [Behaviour]); format_error({undefined_behaviour_callbacks,Behaviour}) -> io_lib:format("behaviour ~w callback functions are undefined", [Behaviour]); @@ -326,23 +351,23 @@ format_error({ill_defined_optional_callbacks,Behaviour}) -> io_lib:format("behaviour ~w optional callback functions erroneously defined", [Behaviour]); format_error({behaviour_info, {_M,F,A}}) -> - io_lib:format("cannot define callback attibute for ~w/~w when " + io_lib:format("cannot define callback attibute for ~tw/~w when " "behaviour_info is defined",[F,A]); format_error({redefine_optional_callback, {F, A}}) -> - io_lib:format("optional callback ~w/~w duplicated", [F, A]); + io_lib:format("optional callback ~tw/~w duplicated", [F, A]); format_error({undefined_callback, {_M, F, A}}) -> - io_lib:format("callback ~w/~w is undefined", [F, A]); + io_lib:format("callback ~tw/~w is undefined", [F, A]); %% --- types and specs --- format_error({singleton_typevar, Name}) -> io_lib:format("type variable ~w is only used once (is unbound)", [Name]); format_error({bad_export_type, _ETs}) -> io_lib:format("bad export_type declaration", []); format_error({duplicated_export_type, {T, A}}) -> - io_lib:format("type ~w/~w already exported", [T, A]); + io_lib:format("type ~tw/~w already exported", [T, A]); format_error({undefined_type, {TypeName, Arity}}) -> - io_lib:format("type ~w~s undefined", [TypeName, gen_type_paren(Arity)]); + io_lib:format("type ~tw~s undefined", [TypeName, gen_type_paren(Arity)]); format_error({unused_type, {TypeName, Arity}}) -> - io_lib:format("type ~w~s is unused", [TypeName, gen_type_paren(Arity)]); + io_lib:format("type ~tw~s is unused", [TypeName, gen_type_paren(Arity)]); format_error({new_builtin_type, {TypeName, Arity}}) -> io_lib:format("type ~w~s is a new builtin type; " "its (re)definition is allowed only until the next release", @@ -354,26 +379,30 @@ format_error({renamed_type, OldName, NewName}) -> io_lib:format("type ~w() is now called ~w(); " "please use the new name instead", [OldName, NewName]); format_error({redefine_type, {TypeName, Arity}}) -> - io_lib:format("type ~w~s already defined", + io_lib:format("type ~tw~s already defined", [TypeName, gen_type_paren(Arity)]); format_error({type_syntax, Constr}) -> - io_lib:format("bad ~w type", [Constr]); + io_lib:format("bad ~tw type", [Constr]); +format_error(old_abstract_code) -> + io_lib:format("abstract code generated before Erlang/OTP 19.0 and " + "having typed record fields cannot be compiled", []); format_error({redefine_spec, {M, F, A}}) -> - io_lib:format("spec for ~w:~w/~w already defined", [M, F, A]); + io_lib:format("spec for ~tw:~tw/~w already defined", [M, F, A]); format_error({redefine_spec, {F, A}}) -> - io_lib:format("spec for ~w/~w already defined", [F, A]); + io_lib:format("spec for ~tw/~w already defined", [F, A]); format_error({redefine_callback, {F, A}}) -> - io_lib:format("callback ~w/~w already defined", [F, A]); + io_lib:format("callback ~tw/~w already defined", [F, A]); format_error({bad_callback, {M, F, A}}) -> - io_lib:format("explicit module not allowed for callback ~w:~w/~w ", [M, F, A]); + io_lib:format("explicit module not allowed for callback ~tw:~tw/~w", + [M, F, A]); format_error({spec_fun_undefined, {F, A}}) -> - io_lib:format("spec for undefined function ~w/~w", [F, A]); + io_lib:format("spec for undefined function ~tw/~w", [F, A]); format_error({missing_spec, {F,A}}) -> - io_lib:format("missing specification for function ~w/~w", [F, A]); + io_lib:format("missing specification for function ~tw/~w", [F, A]); format_error(spec_wrong_arity) -> - "spec has the wrong arity"; + "spec has wrong arity"; format_error(callback_wrong_arity) -> - "callback has the wrong arity"; + "callback has wrong arity"; format_error({deprecated_builtin_type, {Name, Arity}, Replacement, Rel}) -> UseS = case Replacement of @@ -388,11 +417,15 @@ format_error({deprecated_builtin_type, {Name, Arity}, "removed in ~s; use ~s", [Name, Arity, Rel, UseS]); format_error({not_exported_opaque, {TypeName, Arity}}) -> - io_lib:format("opaque type ~w~s is not exported", + io_lib:format("opaque type ~tw~s is not exported", [TypeName, gen_type_paren(Arity)]); format_error({underspecified_opaque, {TypeName, Arity}}) -> - io_lib:format("opaque type ~w~s is underspecified and therefore meaningless", + io_lib:format("opaque type ~tw~s is underspecified and therefore meaningless", [TypeName, gen_type_paren(Arity)]); +format_error({bad_dialyzer_attribute,Term}) -> + io_lib:format("badly formed dialyzer attribute: ~tw", [Term]); +format_error({bad_dialyzer_option,Term}) -> + io_lib:format("unknown dialyzer warning option: ~tw", [Term]); %% --- obsolete? unused? --- format_error({format_error, {Fmt, Args}}) -> io_lib:format(Fmt, Args). @@ -413,6 +446,9 @@ format_mfa({M, F, A}) when is_integer(A) -> format_mf(M, F, ArityString) when is_atom(M), is_atom(F) -> atom_to_list(M) ++ ":" ++ atom_to_list(F) ++ "/" ++ ArityString. +format_mna({M, N, A}) when is_integer(A) -> + atom_to_list(M) ++ ":" ++ atom_to_list(N) ++ gen_type_paren(A). + format_where(L) when is_integer(L) -> io_lib:format("(line ~p)", [L]); format_where({L,C}) when is_integer(L), is_integer(C) -> @@ -459,7 +495,7 @@ used_vars(Exprs, BindingsList) -> %% really all ordsets! -spec(module(AbsForms) -> {ok, Warnings} | {error, Errors, Warnings} when - AbsForms :: [erl_parse:abstract_form()], + AbsForms :: [erl_parse:abstract_form() | erl_parse:form_info()], Warnings :: [{file:filename(),[ErrorInfo]}], Errors :: [{FileName2 :: file:filename(),[ErrorInfo]}], ErrorInfo :: error_info()). @@ -471,7 +507,7 @@ module(Forms) -> -spec(module(AbsForms, FileName) -> {ok, Warnings} | {error, Errors, Warnings} when - AbsForms :: [erl_parse:abstract_form()], + AbsForms :: [erl_parse:abstract_form() | erl_parse:form_info()], FileName :: atom() | string(), Warnings :: [{file:filename(),[ErrorInfo]}], Errors :: [{FileName2 :: file:filename(),[ErrorInfo]}], @@ -484,7 +520,7 @@ module(Forms, FileName) -> -spec(module(AbsForms, FileName, CompileOptions) -> {ok, Warnings} | {error, Errors, Warnings} when - AbsForms :: [erl_parse:abstract_form()], + AbsForms :: [erl_parse:abstract_form() | erl_parse:form_info()], FileName :: atom() | string(), CompileOptions :: [compile:option()], Warnings :: [{file:filename(),[ErrorInfo]}], @@ -514,7 +550,7 @@ start(File, Opts) -> true, Opts)}, {export_all, bool_option(warn_export_all, nowarn_export_all, - false, Opts)}, + true, Opts)}, {export_vars, bool_option(warn_export_vars, nowarn_export_vars, false, Opts)}, @@ -550,7 +586,10 @@ start(File, Opts) -> false, Opts)}, {missing_spec_all, bool_option(warn_missing_spec_all, nowarn_missing_spec_all, - false, Opts)} + false, Opts)}, + {get_stacktrace, + bool_option(warn_get_stacktrace, nowarn_get_stacktrace, + true, Opts)} ], Enabled1 = [Category || {Category,true} <- Enabled0], Enabled = ordsets:from_list(Enabled1), @@ -691,7 +730,12 @@ set_form_file({function,L,N,A,C}, File) -> set_form_file(Form, _File) -> Form. +set_file(Ts, File) when is_list(Ts) -> + [anno_set_file(T, File) || T <- Ts]; set_file(T, File) -> + anno_set_file(T, File). + +anno_set_file(T, File) -> F = fun(Anno) -> erl_anno:set_file(File, Anno) end, erl_parse:map_anno(F, T). @@ -716,17 +760,23 @@ form(Form, #lint{state=State}=St) -> start_state({attribute,Line,module,{_,_}}=Form, St0) -> St1 = add_error(Line, pmod_unsupported, St0), attribute_state(Form, St1#lint{state=attribute}); -start_state({attribute,_,module,M}, St0) -> +start_state({attribute,Line,module,M}, St0) -> St1 = St0#lint{module=M}, - St1#lint{state=attribute}; + St2 = St1#lint{state=attribute}, + check_module_name(M, Line, St2); start_state(Form, St) -> - St1 = add_error(element(2, Form), undefined_module, St), + Anno = case Form of + {eof, L} -> erl_anno:new(L); + %% {warning, Warning} and {error, Error} not possible here. + _ -> element(2, Form) + end, + St1 = add_error(Anno, undefined_module, St), attribute_state(Form, St1#lint{state=attribute}). %% attribute_state(Form, State) -> %% State' -attribute_state({attribute,_L,module,_M}, #lint{module=[]}=St) -> +attribute_state({attribute,_L,module,_M}, #lint{module=''}=St) -> St; attribute_state({attribute,L,module,_M}, St) -> add_error(L, redefine_module, St); @@ -763,8 +813,7 @@ attribute_state(Form, St) -> %% State' %% Allow for record, type and opaque type definitions and spec %% declarations to be intersperced within function definitions. -%% Dialyzer attributes are also allowed everywhere, but are not -%% checked at all. +%% Dialyzer attributes are also allowed everywhere. function_state({attribute,L,record,{Name,Fields}}, St) -> record_def(L, Name, Fields, St); @@ -805,9 +854,10 @@ not_deprecated(Forms, St0) -> {nowarn_deprecated_function, MFAs0} <- lists:flatten([Args]), MFA <- lists:flatten([MFAs0])], Nowarn = [MFA || {MFA,_L} <- MFAsL], - Bad = [MFAL || {{M,F,A},_L}=MFAL <- MFAsL, - otp_internal:obsolete(M, F, A) =:= no], - St1 = func_line_warning(bad_nowarn_deprecated_function, Bad, St0), + ML = [{M,L} || {{M,_F,_A},L} <- MFAsL, is_atom(M)], + St1 = foldl(fun ({M,L}, St2) -> + check_module_name(M, L, St2) + end, St0, ML), St1#lint{not_deprecated = ordsets:from_list(Nowarn)}. %% The nowarn_bif_clash directive is not only deprecated, it's actually an error from R14A @@ -850,7 +900,8 @@ post_traversal_check(Forms, St0) -> StD = check_on_load(StC), StE = check_unused_records(Forms, StD), StF = check_local_opaque_types(StE), - check_callback_information(StF). + StG = check_dialyzer_attribute(Forms, StF), + check_callback_information(StG). %% check_behaviour(State0) -> State %% Check that the behaviour attribute is valid. @@ -914,7 +965,8 @@ behaviour_callbacks(Line, B, St0) -> catch _:_ -> St1 = add_warning(Line, {undefined_behaviour, B}, St0), - {[], [], St1} + St2 = check_module_name(B, Line, St1), + {[], [], St2} end. behaviour_missing_callbacks([{{Line,B},Bfs0,OBfs}|T], St0) -> @@ -1133,7 +1185,7 @@ check_untyped_records(Forms, St0) -> RecNames = dict:fetch_keys(St0#lint.records), %% these are the records with field(s) containing type info TRecNames = [Name || - {attribute,_,type,{{record,Name},Fields,_}} <- Forms, + {attribute,_,record,{Name,Fields}} <- Forms, lists:all(fun ({typed_record_field,_,_}) -> true; (_) -> false end, Fields)], @@ -1143,7 +1195,8 @@ check_untyped_records(Forms, St0) -> [] -> St; % exclude records with no fields [_|_] -> add_warning(L, {untyped_record, N}, St) end - end, St0, RecNames -- TRecNames); + end, St0, ordsets:subtract(ordsets:from_list(RecNames), + ordsets:from_list(TRecNames))); false -> St0 end. @@ -1251,7 +1304,8 @@ exports(#lint{compile = Opts, defined = Defs, exports = Es}) -> -type import() :: {module(), [fa()]} | module(). -spec import(line(), import(), lint_state()) -> lint_state(). -import(Line, {Mod,Fs}, St) -> +import(Line, {Mod,Fs}, St00) -> + St = check_module_name(Mod, Line, St00), Mfs = ordsets:from_list(Fs), case check_imports(Line, Mfs, St#lint.imports) of [] -> @@ -1367,8 +1421,9 @@ call_function(Line, F, A, #lint{usage=Usage0,called=Cd,func=Func,file=File}=St) %% function(Line, Name, Arity, Clauses, State) -> State. function(Line, Name, Arity, Cs, St0) -> - St1 = define_function(Line, Name, Arity, St0#lint{func={Name,Arity}}), - clauses(Cs, St1). + St1 = St0#lint{func={Name,Arity},catch_scope=none}, + St2 = define_function(Line, Name, Arity, St1), + clauses(Cs, St2). -spec define_function(line(), atom(), arity(), lint_state()) -> lint_state(). @@ -1488,7 +1543,7 @@ pattern({op,_Line,'++',{string,_Li,_S},R}, Vt, Old, Bvt, St) -> pattern({match,_Line,Pat1,Pat2}, Vt, Old, Bvt, St0) -> {Lvt,Bvt1,St1} = pattern(Pat1, Vt, Old, Bvt, St0), {Rvt,Bvt2,St2} = pattern(Pat2, Vt, Old, Bvt, St1), - St3 = reject_bin_alias(Pat1, Pat2, St2), + St3 = reject_invalid_alias(Pat1, Pat2, Vt, St2), {vtmerge_pat(Lvt, Rvt),vtmerge_pat(Bvt1,Bvt2),St3}; %% Catch legal constant expressions, including unary +,-. pattern(Pat, _Vt, _Old, _Bvt, St) -> @@ -1503,56 +1558,77 @@ pattern_list(Ps, Vt, Old, Bvt0, St) -> {vtmerge_pat(Pvt, Psvt),vtmerge_pat(Bvt,Bvt1),St1} end, {[],[],St}, Ps). -%% reject_bin_alias(Pat, Expr, St) -> St' + + +%% reject_invalid_alias(Pat, Expr, Vt, St) -> St' %% Reject aliases for binary patterns at the top level. +%% Reject aliases for maps patterns at the top level. +%% The variables table (Vt) are for maps checkking. -reject_bin_alias_expr({bin,_,_}=P, {match,_,P0,E}, St0) -> - St = reject_bin_alias(P, P0, St0), - reject_bin_alias_expr(P, E, St); -reject_bin_alias_expr({match,_,_,_}=P, {match,_,P0,E}, St0) -> - St = reject_bin_alias(P, P0, St0), - reject_bin_alias_expr(P, E, St); -reject_bin_alias_expr(_, _, St) -> St. +reject_invalid_alias_expr({bin,_,_}=P, {match,_,P0,E}, Vt, St0) -> + St = reject_invalid_alias(P, P0, Vt, St0), + reject_invalid_alias_expr(P, E, Vt, St); +reject_invalid_alias_expr({map,_,_}=P, {match,_,P0,E}, Vt, St0) -> + St = reject_invalid_alias(P, P0, Vt, St0), + reject_invalid_alias_expr(P, E, Vt, St); +reject_invalid_alias_expr({match,_,_,_}=P, {match,_,P0,E}, Vt, St0) -> + St = reject_invalid_alias(P, P0, Vt, St0), + reject_invalid_alias_expr(P, E, Vt, St); +reject_invalid_alias_expr(_, _, _, St) -> St. -%% reject_bin_alias(Pat1, Pat2, St) -> St' + +%% reject_invalid_alias(Pat1, Pat2, St) -> St' %% Aliases of binary patterns, such as <<A:8>> = <<B:4,C:4>> or even %% <<A:8>> = <<A:8>>, are not allowed. Traverse the patterns in parallel %% and generate an error if any binary aliases are found. %% We generate an error even if is obvious that the overall pattern can't %% possibly match, for instance, {a,<<A:8>>,c}={x,<<A:8>>} WILL generate an %% error. +%% Maps should reject unbound variables here. -reject_bin_alias({bin,Line,_}, {bin,_,_}, St) -> +reject_invalid_alias({bin,Line,_}, {bin,_,_}, _, St) -> add_error(Line, illegal_bin_pattern, St); -reject_bin_alias({cons,_,H1,T1}, {cons,_,H2,T2}, St0) -> - St = reject_bin_alias(H1, H2, St0), - reject_bin_alias(T1, T2, St); -reject_bin_alias({tuple,_,Es1}, {tuple,_,Es2}, St) -> - reject_bin_alias_list(Es1, Es2, St); -reject_bin_alias({record,_,Name1,Pfs1}, {record,_,Name2,Pfs2}, +reject_invalid_alias({map,_Line,Ps1}, {map,_,Ps2}, Vt, St0) -> + Fun = fun ({map_field_exact,L,{var,_,K},_V}, Sti) -> + case is_var_bound(K,Vt) of + true -> + Sti; + false -> + add_error(L, {unbound_var,K}, Sti) + end; + ({map_field_exact,_L,_K,_V}, Sti) -> + Sti + end, + foldl(Fun, foldl(Fun, St0, Ps1), Ps2); +reject_invalid_alias({cons,_,H1,T1}, {cons,_,H2,T2}, Vt, St0) -> + St = reject_invalid_alias(H1, H2, Vt, St0), + reject_invalid_alias(T1, T2, Vt, St); +reject_invalid_alias({tuple,_,Es1}, {tuple,_,Es2}, Vt, St) -> + reject_invalid_alias_list(Es1, Es2, Vt, St); +reject_invalid_alias({record,_,Name1,Pfs1}, {record,_,Name2,Pfs2}, Vt, #lint{records=Recs}=St) -> case {dict:find(Name1, Recs),dict:find(Name2, Recs)} of {{ok,{_Line1,Fields1}},{ok,{_Line2,Fields2}}} -> - reject_bin_alias_rec(Pfs1, Pfs2, Fields1, Fields2, St); + reject_invalid_alias_rec(Pfs1, Pfs2, Fields1, Fields2, Vt, St); {_,_} -> %% One or more non-existing records. (An error messages has %% already been generated, so we are done here.) St end; -reject_bin_alias({match,_,P1,P2}, P, St0) -> - St = reject_bin_alias(P1, P, St0), - reject_bin_alias(P2, P, St); -reject_bin_alias(P, {match,_,_,_}=M, St) -> - reject_bin_alias(M, P, St); -reject_bin_alias(_P1, _P2, St) -> St. - -reject_bin_alias_list([E1|Es1], [E2|Es2], St0) -> - St = reject_bin_alias(E1, E2, St0), - reject_bin_alias_list(Es1, Es2, St); -reject_bin_alias_list(_, _, St) -> St. - -reject_bin_alias_rec(PfsA0, PfsB0, FieldsA0, FieldsB0, St) -> +reject_invalid_alias({match,_,P1,P2}, P, Vt, St0) -> + St = reject_invalid_alias(P1, P, Vt, St0), + reject_invalid_alias(P2, P, Vt, St); +reject_invalid_alias(P, {match,_,_,_}=M, Vt, St) -> + reject_invalid_alias(M, P, Vt, St); +reject_invalid_alias(_P1, _P2, _Vt, St) -> St. + +reject_invalid_alias_list([E1|Es1], [E2|Es2], Vt, St0) -> + St = reject_invalid_alias(E1, E2, Vt, St0), + reject_invalid_alias_list(Es1, Es2, Vt, St); +reject_invalid_alias_list(_, _, _, St) -> St. + +reject_invalid_alias_rec(PfsA0, PfsB0, FieldsA0, FieldsB0, Vt, St) -> %% We treat records as if they have been converted to tuples. PfsA1 = rbia_field_vars(PfsA0), PfsB1 = rbia_field_vars(PfsB0), @@ -1568,7 +1644,7 @@ reject_bin_alias_rec(PfsA0, PfsB0, FieldsA0, FieldsB0, St) -> D = sofs:projection({external,fun({_,_,P1,_,P2}) -> {P1,P2} end}, C), E = sofs:to_external(D), {Ps1,Ps2} = lists:unzip(E), - reject_bin_alias_list(Ps1, Ps2, St). + reject_invalid_alias_list(Ps1, Ps2, Vt, St). rbia_field_vars(Fs) -> [{Name,Pat} || {record_field,_,{atom,_,Name},Pat} <- Fs]. @@ -1730,7 +1806,8 @@ bit_size({atom,_Line,all}, _Vt, St, _Check) -> {all,[],St}; bit_size(Size, Vt, St, Check) -> %% Try to safely evaluate Size if constant to get size, %% otherwise just treat it as an expression. - case is_gexpr(Size, St#lint.records) of + Info = is_guard_test2_info(St), + case is_gexpr(Size, Info) of true -> case erl_eval:partial_eval(Size) of {integer,_ILn,I} -> {I,[],St}; @@ -1965,77 +2042,104 @@ gexpr_list(Es, Vt, St) -> %% is_guard_test(Expression) -> boolean(). %% Test if a general expression is a guard test. +%% +%% Note: Only use this function in contexts where there can be +%% no definition of a local function that may override a guard BIF +%% (for example, in the shell). -spec is_guard_test(Expr) -> boolean() when Expr :: erl_parse:abstract_expr(). is_guard_test(E) -> - is_guard_test2(E, dict:new()). + is_guard_test2(E, {dict:new(),fun(_) -> false end}). %% is_guard_test(Expression, Forms) -> boolean(). is_guard_test(Expression, Forms) -> + is_guard_test(Expression, Forms, fun(_) -> false end). + + +%% is_guard_test(Expression, Forms, IsOverridden) -> boolean(). +%% Test if a general expression is a guard test. +%% +%% IsOverridden({Name,Arity}) should return 'true' if Name/Arity is +%% a local or imported function in the module. If the abstract code has +%% passed through erl_expand_records, any call without an explicit +%% module is to a local function, so IsOverridden can be defined as: +%% +%% fun(_) -> true end +%% +-spec is_guard_test(Expr, Forms, IsOverridden) -> boolean() when + Expr :: erl_parse:abstract_expr(), + Forms :: [erl_parse:abstract_form() | erl_parse:form_info()], + IsOverridden :: fun((fa()) -> boolean()). + +is_guard_test(Expression, Forms, IsOverridden) -> RecordAttributes = [A || A = {attribute, _, record, _D} <- Forms], St0 = foldl(fun(Attr0, St1) -> Attr = set_file(Attr0, "none"), attribute_state(Attr, St1) end, start(), RecordAttributes), - is_guard_test2(set_file(Expression, "nofile"), St0#lint.records). + is_guard_test2(set_file(Expression, "nofile"), + {St0#lint.records,IsOverridden}). %% is_guard_test2(Expression, RecordDefs :: dict:dict()) -> boolean(). -is_guard_test2({call,Line,{atom,Lr,record},[E,A]}, RDs) -> - is_gexpr({call,Line,{atom,Lr,is_record},[E,A]}, RDs); -is_guard_test2({call,_Line,{atom,_La,Test},As}=Call, RDs) -> - case erl_internal:type_test(Test, length(As)) of - true -> is_gexpr_list(As, RDs); - false -> is_gexpr(Call, RDs) - end; -is_guard_test2(G, RDs) -> +is_guard_test2({call,Line,{atom,Lr,record},[E,A]}, Info) -> + is_gexpr({call,Line,{atom,Lr,is_record},[E,A]}, Info); +is_guard_test2({call,_Line,{atom,_La,Test},As}=Call, {_,IsOverridden}=Info) -> + A = length(As), + not IsOverridden({Test,A}) andalso + case erl_internal:type_test(Test, A) of + true -> is_gexpr_list(As, Info); + false -> is_gexpr(Call, Info) + end; +is_guard_test2(G, Info) -> %%Everything else is a guard expression. - is_gexpr(G, RDs). + is_gexpr(G, Info). %% is_guard_expr(Expression) -> boolean(). %% Test if an expression is a guard expression. is_guard_expr(E) -> is_gexpr(E, []). -is_gexpr({var,_L,_V}, _RDs) -> true; -is_gexpr({char,_L,_C}, _RDs) -> true; -is_gexpr({integer,_L,_I}, _RDs) -> true; -is_gexpr({float,_L,_F}, _RDs) -> true; -is_gexpr({atom,_L,_A}, _RDs) -> true; -is_gexpr({string,_L,_S}, _RDs) -> true; -is_gexpr({nil,_L}, _RDs) -> true; -is_gexpr({cons,_L,H,T}, RDs) -> is_gexpr_list([H,T], RDs); -is_gexpr({tuple,_L,Es}, RDs) -> is_gexpr_list(Es, RDs); -%%is_gexpr({struct,_L,_Tag,Es}, RDs) -> -%% is_gexpr_list(Es, RDs); -is_gexpr({record_index,_L,_Name,Field}, RDs) -> - is_gexpr(Field, RDs); -is_gexpr({record_field,_L,Rec,_Name,Field}, RDs) -> - is_gexpr_list([Rec,Field], RDs); -is_gexpr({record,L,Name,Inits}, RDs) -> - is_gexpr_fields(Inits, L, Name, RDs); -is_gexpr({bin,_L,Fs}, RDs) -> +is_gexpr({var,_L,_V}, _Info) -> true; +is_gexpr({char,_L,_C}, _Info) -> true; +is_gexpr({integer,_L,_I}, _Info) -> true; +is_gexpr({float,_L,_F}, _Info) -> true; +is_gexpr({atom,_L,_A}, _Info) -> true; +is_gexpr({string,_L,_S}, _Info) -> true; +is_gexpr({nil,_L}, _Info) -> true; +is_gexpr({cons,_L,H,T}, Info) -> is_gexpr_list([H,T], Info); +is_gexpr({tuple,_L,Es}, Info) -> is_gexpr_list(Es, Info); +%%is_gexpr({struct,_L,_Tag,Es}, Info) -> +%% is_gexpr_list(Es, Info); +is_gexpr({record_index,_L,_Name,Field}, Info) -> + is_gexpr(Field, Info); +is_gexpr({record_field,_L,Rec,_Name,Field}, Info) -> + is_gexpr_list([Rec,Field], Info); +is_gexpr({record,L,Name,Inits}, Info) -> + is_gexpr_fields(Inits, L, Name, Info); +is_gexpr({bin,_L,Fs}, Info) -> all(fun ({bin_element,_Line,E,Sz,_Ts}) -> - is_gexpr(E, RDs) and (Sz =:= default orelse is_gexpr(Sz, RDs)) + is_gexpr(E, Info) and (Sz =:= default orelse is_gexpr(Sz, Info)) end, Fs); -is_gexpr({call,_L,{atom,_Lf,F},As}, RDs) -> +is_gexpr({call,_L,{atom,_Lf,F},As}, {_,IsOverridden}=Info) -> A = length(As), - erl_internal:guard_bif(F, A) andalso is_gexpr_list(As, RDs); -is_gexpr({call,_L,{remote,_Lr,{atom,_Lm,erlang},{atom,_Lf,F}},As}, RDs) -> + not IsOverridden({F,A}) andalso erl_internal:guard_bif(F, A) + andalso is_gexpr_list(As, Info); +is_gexpr({call,_L,{remote,_Lr,{atom,_Lm,erlang},{atom,_Lf,F}},As}, Info) -> A = length(As), (erl_internal:guard_bif(F, A) orelse is_gexpr_op(F, A)) - andalso is_gexpr_list(As, RDs); -is_gexpr({call,L,{tuple,Lt,[{atom,Lm,erlang},{atom,Lf,F}]},As}, RDs) -> - is_gexpr({call,L,{remote,Lt,{atom,Lm,erlang},{atom,Lf,F}},As}, RDs); -is_gexpr({op,_L,Op,A}, RDs) -> - is_gexpr_op(Op, 1) andalso is_gexpr(A, RDs); -is_gexpr({op,_L,'andalso',A1,A2}, RDs) -> - is_gexpr_list([A1,A2], RDs); -is_gexpr({op,_L,'orelse',A1,A2}, RDs) -> - is_gexpr_list([A1,A2], RDs); -is_gexpr({op,_L,Op,A1,A2}, RDs) -> - is_gexpr_op(Op, 2) andalso is_gexpr_list([A1,A2], RDs); -is_gexpr(_Other, _RDs) -> false. + andalso is_gexpr_list(As, Info); +is_gexpr({call,L,{tuple,Lt,[{atom,Lm,erlang},{atom,Lf,F}]},As}, Info) -> + is_gexpr({call,L,{remote,Lt,{atom,Lm,erlang},{atom,Lf,F}},As}, Info); +is_gexpr({op,_L,Op,A}, Info) -> + is_gexpr_op(Op, 1) andalso is_gexpr(A, Info); +is_gexpr({op,_L,'andalso',A1,A2}, Info) -> + is_gexpr_list([A1,A2], Info); +is_gexpr({op,_L,'orelse',A1,A2}, Info) -> + is_gexpr_list([A1,A2], Info); +is_gexpr({op,_L,Op,A1,A2}, Info) -> + is_gexpr_op(Op, 2) andalso is_gexpr_list([A1,A2], Info); +is_gexpr(_Other, _Info) -> false. is_gexpr_op(Op, A) -> try erl_internal:op_type(Op, A) of @@ -2047,14 +2151,14 @@ is_gexpr_op(Op, A) -> catch _:_ -> false end. -is_gexpr_list(Es, RDs) -> all(fun (E) -> is_gexpr(E, RDs) end, Es). +is_gexpr_list(Es, Info) -> all(fun (E) -> is_gexpr(E, Info) end, Es). -is_gexpr_fields(Fs, L, Name, RDs) -> +is_gexpr_fields(Fs, L, Name, {RDs,_}=Info) -> IFs = case dict:find(Name, RDs) of {ok,{_Line,Fields}} -> Fs ++ init_fields(Fs, L, Fields); error -> Fs end, - all(fun ({record_field,_Lf,_Name,V}) -> is_gexpr(V, RDs); + all(fun ({record_field,_Lf,_Name,V}) -> is_gexpr(V, Info); (_Other) -> false end, IFs). %% exprs(Sequence, VarTable, State) -> @@ -2185,11 +2289,18 @@ expr({call,L,{tuple,Lt,[{atom,Lm,erlang},{atom,Lf,is_record}]},As}, Vt, St) -> expr({call,Line,{remote,_Lr,{atom,_Lm,M},{atom,Lf,F}},As}, Vt, St0) -> St1 = keyword_warning(Lf, F, St0), St2 = check_remote_function(Line, M, F, As, St1), - expr_list(As, Vt, St2); + St3 = check_module_name(M, Line, St2), + expr_list(As, Vt, St3); expr({call,Line,{remote,_Lr,M,F},As}, Vt, St0) -> St1 = keyword_warning(Line, M, St0), St2 = keyword_warning(Line, F, St1), - expr_list([M,F|As], Vt, St2); + St3 = case M of + {atom,Lm,Mod} -> + check_module_name(Mod, Lm, St2); + _ -> + St2 + end, + expr_list([M,F|As], Vt, St3); expr({call,Line,{atom,La,F},As}, Vt, St0) -> St1 = keyword_warning(La, F, St0), {Asvt,St2} = expr_list(As, Vt, St1), @@ -2251,26 +2362,28 @@ expr({call,Line,F,As}, Vt, St0) -> expr({'try',Line,Es,Scs,Ccs,As}, Vt, St0) -> %% Currently, we don't allow any exports because later %% passes cannot handle exports in combination with 'after'. - {Evt0,St1} = exprs(Es, Vt, St0), + {Evt0,St1} = exprs(Es, Vt, St0#lint{catch_scope=wrong_part_of_try}), TryLine = {'try',Line}, Uvt = vtunsafe(TryLine, Evt0, Vt), Evt1 = vtupdate(Uvt, Evt0), - {Sccs,St2} = icrt_clauses(Scs++Ccs, TryLine, vtupdate(Evt1, Vt), St1), + {Sccs,St2} = try_clauses(Scs, Ccs, TryLine, + vtupdate(Evt1, Vt), St1), Rvt0 = Sccs, Rvt1 = vtupdate(vtunsafe(TryLine, Rvt0, Vt), Rvt0), Evt2 = vtmerge(Evt1, Rvt1), {Avt0,St} = exprs(As, vtupdate(Evt2, Vt), St2), Avt1 = vtupdate(vtunsafe(TryLine, Avt0, Vt), Avt0), Avt = vtmerge(Evt2, Avt1), - {Avt,St}; + {Avt,St#lint{catch_scope=after_try}}; expr({'catch',Line,E}, Vt, St0) -> %% No new variables added, flag new variables as unsafe. {Evt,St} = expr(E, Vt, St0), - {vtupdate(vtunsafe({'catch',Line}, Evt, Vt), Evt),St}; + {vtupdate(vtunsafe({'catch',Line}, Evt, Vt), Evt), + St#lint{catch_scope=after_old_catch}}; expr({match,_Line,P,E}, Vt, St0) -> {Evt,St1} = expr(E, Vt, St0), {Pvt,Bvt,St2} = pattern(P, vtupdate(Evt, Vt), St1), - St = reject_bin_alias_expr(P, E, St2), + St = reject_invalid_alias_expr(P, E, Vt, St2), {vtupdate(Bvt, vtmerge(Evt, Pvt)),St}; %% No comparison or boolean operators yet. expr({op,_Line,_Op,A}, Vt, St) -> @@ -2367,7 +2480,7 @@ is_valid_call(Call) -> _ -> true end. -%% is_valid_map_key(K,St) -> true | false +%% is_valid_map_key(K) -> true | false %% variables are allowed for patterns only at the top of the tree is_valid_map_key({var,_,_}) -> true; @@ -2433,7 +2546,10 @@ record_def(Line, Name, Fs0, St0) -> true -> add_error(Line, {redefine_record,Name}, St0); false -> {Fs1,St1} = def_fields(normalise_fields(Fs0), Name, St0), - St1#lint{records=dict:store(Name, {Line,Fs1}, St1#lint.records)} + St2 = St1#lint{records=dict:store(Name, {Line,Fs1}, + St1#lint.records)}, + Types = [T || {typed_record_field, _, T} <- Fs0], + check_type({type, nowarn(), product, Types}, St2) end. %% def_fields([RecDef], RecordName, State) -> {[DefField],State}. @@ -2636,11 +2752,8 @@ find_field(_F, []) -> error. %% Attr :: 'type' | 'opaque' %% Checks that a type definition is valid. -type_def(_Attr, _Line, {record, _RecName}, Fields, [], St0) -> - %% The record field names and such are checked in the record format. - %% We only need to check the types. - Types = [T || {typed_record_field, _, T} <- Fields], - check_type({type, nowarn(), product, Types}, St0); +-dialyzer({no_match, type_def/6}). + type_def(Attr, Line, TypeName, ProtoType, Args, St0) -> TypeDefs = St0#lint.types, Arity = length(Args), @@ -2702,10 +2815,9 @@ check_type(Types, St) -> check_type({ann_type, _L, [_Var, Type]}, SeenVars, St) -> check_type(Type, SeenVars, St); -check_type({paren_type, _L, [Type]}, SeenVars, St) -> - check_type(Type, SeenVars, St); check_type({remote_type, L, [{atom, _, Mod}, {atom, _, Name}, Args]}, - SeenVars, St0) -> + SeenVars, St00) -> + St0 = check_module_name(Mod, L, St00), St = deprecated_type(L, Mod, Name, Args, St0), CurrentMod = St#lint.module, case Mod =:= CurrentMod of @@ -2743,10 +2855,8 @@ check_type({type, L, range, [From, To]}, SeenVars, St) -> _ -> add_error(L, {type_syntax, range}, St) end, {SeenVars, St1}; -check_type({type, L, map, any}, SeenVars, St) -> - %% To get usage right while map/0 is a newly_introduced_builtin_type. - St1 = used_type({map, 0}, L, St), - {SeenVars, St1}; +check_type({type, _L, map, any}, SeenVars, St) -> + {SeenVars, St}; check_type({type, _L, map, Pairs}, SeenVars, St) -> lists:foldl(fun(Pair, {AccSeenVars, AccSt}) -> check_type(Pair, AccSeenVars, AccSt) @@ -2803,6 +2913,8 @@ check_type({user_type, L, TypeName, Args}, SeenVars, St) -> lists:foldl(fun(T, {AccSeenVars, AccSt}) -> check_type(T, AccSeenVars, AccSt) end, {SeenVars, St1}, Args); +check_type([{typed_record_field,Field,_T}|_], SeenVars, St) -> + {SeenVars, add_error(element(2, Field), old_abstract_code, St)}; check_type(I, SeenVars, St) -> case erl_eval:partial_eval(I) of {integer,_ILn,_Integer} -> {SeenVars, St}; @@ -2852,7 +2964,6 @@ used_type(TypePair, L, #lint{usage = Usage, file = File} = St) -> is_default_type({Name, NumberOfTypeVariables}) -> erl_internal:is_type(Name, NumberOfTypeVariables). -is_newly_introduced_builtin_type({map, 0}) -> true; is_newly_introduced_builtin_type({Name, _}) when is_atom(Name) -> false. is_obsolete_builtin_type(TypePair) -> @@ -2865,15 +2976,16 @@ obsolete_builtin_type({Name, A}) when is_atom(Name), is_integer(A) -> no. %% spec_decl(Line, Fun, Types, State) -> State. -spec_decl(Line, MFA0, TypeSpecs, St0 = #lint{specs = Specs, module = Mod}) -> +spec_decl(Line, MFA0, TypeSpecs, St00 = #lint{specs = Specs, module = Mod}) -> MFA = case MFA0 of {F, Arity} -> {Mod, F, Arity}; {_M, _F, Arity} -> MFA0 end, + St0 = check_module_name(element(1, MFA), Line, St00), St1 = St0#lint{specs = dict:store(MFA, Line, Specs)}, case dict:is_key(MFA, Specs) of true -> add_error(Line, {redefine_spec, MFA0}, St1); - false -> check_specs(TypeSpecs, Arity, St1) + false -> check_specs(TypeSpecs, spec_wrong_arity, Arity, St1) end. %% callback_decl(Line, Fun, Types, State) -> State. @@ -2881,13 +2993,16 @@ spec_decl(Line, MFA0, TypeSpecs, St0 = #lint{specs = Specs, module = Mod}) -> callback_decl(Line, MFA0, TypeSpecs, St0 = #lint{callbacks = Callbacks, module = Mod}) -> case MFA0 of - {_M, _F, _A} -> add_error(Line, {bad_callback, MFA0}, St0); + {M, _F, _A} -> + St1 = check_module_name(M, Line, St0), + add_error(Line, {bad_callback, MFA0}, St1); {F, Arity} -> MFA = {Mod, F, Arity}, St1 = St0#lint{callbacks = dict:store(MFA, Line, Callbacks)}, case dict:is_key(MFA, Callbacks) of true -> add_error(Line, {redefine_callback, MFA0}, St1); - false -> check_specs(TypeSpecs, Arity, St1) + false -> check_specs(TypeSpecs, callback_wrong_arity, + Arity, St1) end end. @@ -2924,7 +3039,17 @@ is_fa({FuncName, Arity}) when is_atom(FuncName), is_integer(Arity), Arity >= 0 -> true; is_fa(_) -> false. -check_specs([FunType|Left], Arity, St0) -> +check_module_name(M, Line, St) -> + case is_latin1_name(M) of + true -> St; + false -> + add_error(Line, non_latin1_module_unsupported, St) + end. + +is_latin1_name(Name) -> + io_lib:latin1_char_list(atom_to_list(Name)). + +check_specs([FunType|Left], ETag, Arity, St0) -> {FunType1, CTypes} = case FunType of {type, _, bounded_fun, [FT = {type, _, 'fun', _}, Cs]} -> @@ -2932,18 +3057,16 @@ check_specs([FunType|Left], Arity, St0) -> {FT, lists:append(Types0)}; {type, _, 'fun', _} = FT -> {FT, []} end, - SpecArity = - case FunType1 of - {type, L, 'fun', [any, _]} -> any; - {type, L, 'fun', [{type, _, product, D}, _]} -> length(D) - end, + {type, L, 'fun', [{type, _, product, D}, _]} = FunType1, + SpecArity = length(D), St1 = case Arity =:= SpecArity of true -> St0; - false -> add_error(L, spec_wrong_arity, St0) + false -> %% Cannot happen if called from the compiler. + add_error(L, ETag, St0) end, St2 = check_type({type, nowarn(), product, [FunType1|CTypes]}, St1), - check_specs(Left, Arity, St2); -check_specs([], _Arity, St) -> + check_specs(Left, ETag, Arity, St2); +check_specs([], _ETag, _Arity, St) -> St. nowarn() -> @@ -2985,9 +3108,10 @@ add_missing_spec_warnings(Forms, St0, Type) -> [{FA,L} || {function,L,F,A,_} <- Forms, not lists:member(FA = {F,A}, Specs)]; exported -> - Exps = gb_sets:to_list(St0#lint.exports) -- pseudolocals(), + Exps0 = gb_sets:to_list(St0#lint.exports) -- pseudolocals(), + Exps = Exps0 -- Specs, [{FA,L} || {function,L,F,A,_} <- Forms, - member(FA = {F,A}, Exps -- Specs)] + member(FA = {F,A}, Exps)] end, foldl(fun ({FA,L}, St) -> add_warning(L, {missing_spec,FA}, St) @@ -3000,7 +3124,9 @@ check_unused_types(Forms, #lint{usage=Usage, types=Ts, exp_types=ExpTs}=St) -> L = gb_sets:to_list(ExpTs) ++ dict:fetch_keys(D), UsedTypes = gb_sets:from_list(L), FoldFun = - fun(Type, #typeinfo{line = FileLine}, AccSt) -> + fun({{record, _}=_Type, 0}, _, AccSt) -> + AccSt; % Before Erlang/OTP 19.0 + (Type, #typeinfo{line = FileLine}, AccSt) -> case loc(FileLine, AccSt) of {FirstFile, _} -> case gb_sets:is_member(Type, UsedTypes) of @@ -3034,6 +3160,70 @@ check_local_opaque_types(St) -> end, dict:fold(FoldFun, St, Ts). +check_dialyzer_attribute(Forms, St0) -> + Vals = [{L,V} || + {attribute,L,dialyzer,Val} <- Forms, + V0 <- lists:flatten([Val]), + V <- case V0 of + {O,F} -> + [{A,B} || + A <- lists:flatten([O]), + B <- lists:flatten([F])]; + T -> [T] + end], + {Wellformed, Bad} = + lists:partition(fun ({_,{Option,FA}}) when is_atom(Option) -> + is_fa(FA); + ({_,Option}) when is_atom(Option) -> true; + (_) -> false + end, Vals), + St1 = foldl(fun ({L,Term}, St) -> + add_error(L, {bad_dialyzer_attribute,Term}, St) + end, St0, Bad), + DefFunctions = (gb_sets:to_list(St0#lint.defined) -- pseudolocals()), + Fun = fun ({L,{Option,FA}}, St) -> + case is_function_dialyzer_option(Option) of + true -> + case lists:member(FA, DefFunctions) of + true -> St; + false -> + add_error(L, {undefined_function,FA}, St) + end; + false -> + add_error(L, {bad_dialyzer_option,Option}, St) + end; + ({L,Option}, St) -> + case is_module_dialyzer_option(Option) of + true -> St; + false -> + add_error(L, {bad_dialyzer_option,Option}, St) + end + end, + foldl(Fun, St1, Wellformed). + +is_function_dialyzer_option(nowarn_function) -> true; +is_function_dialyzer_option(Option) -> + is_module_dialyzer_option(Option). + +is_module_dialyzer_option(Option) -> + lists:member(Option, + [no_return,no_unused,no_improper_lists,no_fun_app, + no_match,no_opaque,no_fail_call,no_contracts, + no_behaviours,no_undefined_callbacks,unmatched_returns, + error_handling,race_conditions,no_missing_calls, + specdiffs,overspecs,underspecs,unknown]). + +%% try_catch_clauses(Scs, Ccs, In, ImportVarTable, State) -> +%% {UpdVt,State}. + +try_clauses(Scs, Ccs, In, Vt, St0) -> + {Csvt0,St1} = icrt_clauses(Scs, Vt, St0), + St2 = St1#lint{catch_scope=try_catch}, + {Csvt1,St3} = icrt_clauses(Ccs, Vt, St2), + Csvt = Csvt0 ++ Csvt1, + UpdVt = icrt_export(Csvt, Vt, In, St3), + {UpdVt,St3}. + %% icrt_clauses(Clauses, In, ImportVarTable, State) -> %% {UpdVt,State}. @@ -3048,13 +3238,13 @@ icrt_clauses(Cs, In, Vt, St0) -> icrt_clauses(Cs, Vt, St) -> mapfoldl(fun (C, St0) -> icrt_clause(C, Vt, St0) end, St, Cs). -icrt_clause({clause,_Line,H,G,B}, Vt0, St0) -> +icrt_clause({clause,_Line,H,G,B}, Vt0, #lint{catch_scope=Scope}=St0) -> {Hvt,Binvt,St1} = head(H, Vt0, St0), Vt1 = vtupdate(Hvt, Binvt), {Gvt,St2} = guard(G, vtupdate(Vt1, Vt0), St1), Vt2 = vtupdate(Gvt, Vt1), {Bvt,St3} = exprs(B, vtupdate(Vt2, Vt0), St2), - {vtupdate(Bvt, Vt2),St3}. + {vtupdate(Bvt, Vt2),St3#lint{catch_scope=Scope}}. icrt_export(Vts, Vt, {Tag,Attrs}, St) -> {_File,Loc} = loc(Attrs, St), @@ -3159,7 +3349,8 @@ lc_quals([{b_generate,_Line,P,E} | Qs], Vt0, Uvt0, St0) -> {Vt,Uvt,St} = handle_generator(P,E,Vt0,Uvt0,St1), lc_quals(Qs, Vt, Uvt, St); lc_quals([F|Qs], Vt, Uvt, St0) -> - {Fvt,St1} = case is_guard_test2(F, St0#lint.records) of + Info = is_guard_test2_info(St0), + {Fvt,St1} = case is_guard_test2(F, Info) of true -> guard_test(F, Vt, St0); false -> expr(F, Vt, St0) end, @@ -3167,6 +3358,12 @@ lc_quals([F|Qs], Vt, Uvt, St0) -> lc_quals([], Vt, Uvt, St) -> {Vt, Uvt, St}. +is_guard_test2_info(#lint{records=RDs,locals=Locals,imports=Imports}) -> + {RDs,fun(FA) -> + is_local_function(Locals, FA) orelse + is_imported_function(Imports, FA) + end}. + handle_generator(P,E,Vt,Uvt,St0) -> {Evt,St1} = expr(E, Vt, St0), %% Forget variables local to E immediately. @@ -3187,8 +3384,8 @@ handle_generator(P,E,Vt,Uvt,St0) -> handle_bitstring_gen_pat({bin,_,Segments=[_|_]},St) -> case lists:last(Segments) of {bin_element,Line,{var,_,_},default,Flags} when is_list(Flags) -> - case member(binary, Flags) orelse member(bits, Flags) - orelse member(bitstring, Flags) of + case member(binary, Flags) orelse member(bytes, Flags) + orelse member(bits, Flags) orelse member(bitstring, Flags) of true -> add_error(Line, unsized_binary_in_bin_gen_pattern, St); false -> @@ -3400,6 +3597,14 @@ warn_unused_vars(U, Vt, St0) -> UVt = map(fun ({V,{State,_,Ls}}) -> {V,{State,used,Ls}} end, U), {vtmerge(Vt, UVt), St1}. + +is_var_bound(V, Vt) -> + case orddict:find(V, Vt) of + {ok,{bound,_Usage,_}} -> true; + _ -> false + end. + + %% vtupdate(UpdVarTable, VarTable) -> VarTable. %% Add the variables in the updated vartable to VarTable. The variables %% will be updated with their property in UpdVarTable. The state of @@ -3482,13 +3687,6 @@ vt_no_unused(Vt) -> [V || {_,{_,U,_L}}=V <- Vt, U =/= unused]. copy_expr(Expr, Anno) -> erl_parse:map_anno(fun(_A) -> Anno end, Expr). -%% modify_line(Form, Fun) -> Form -%% modify_line(Expression, Fun) -> Expression -%% Applies Fun to each line number occurrence. - -modify_line(T, F0) -> - erl_parse:map_anno(F0, T). - %% Check a record_info call. We have already checked that it is not %% shadowed by an import. @@ -3510,7 +3708,8 @@ has_wildcard_field([]) -> false. check_remote_function(Line, M, F, As, St0) -> St1 = deprecated_function(Line, M, F, As, St0), St2 = check_qlc_hrl(Line, M, F, As, St1), - format_function(Line, M, F, As, St2). + St3 = check_get_stacktrace(Line, M, F, As, St2), + format_function(Line, M, F, As, St3). %% check_qlc_hrl(Line, ModName, FuncName, [Arg], State) -> State %% Add warning if qlc:q/1,2 has been called but qlc.hrl has not @@ -3529,6 +3728,8 @@ check_qlc_hrl(Line, M, F, As, St) -> %% deprecated_function(Line, ModName, FuncName, [Arg], State) -> State. %% Add warning for calls to deprecated functions. +-dialyzer({no_match, deprecated_function/5}). + deprecated_function(Line, M, F, As, St) -> Arity = length(As), MFA = {M, F, Arity}, @@ -3557,6 +3758,25 @@ deprecated_function(Line, M, F, As, St) -> St end. +check_get_stacktrace(Line, erlang, get_stacktrace, [], St) -> + case St of + #lint{catch_scope=none} -> + St; + #lint{catch_scope=try_catch} -> + St; + #lint{catch_scope=Scope} -> + case is_warn_enabled(get_stacktrace, St) of + false -> + St; + true -> + add_warning(Line, {get_stacktrace,Scope}, St) + end + end; +check_get_stacktrace(_, _, _, _, St) -> + St. + +-dialyzer({no_match, deprecated_type/5}). + deprecated_type(L, M, N, As, St) -> NAs = length(As), case otp_internal:obsolete_type(M, N, NAs) of @@ -3567,6 +3787,8 @@ deprecated_type(L, M, N, As, St) -> false -> St end; + {removed, Replacement, Rel} -> + add_warning(L, {removed_type, {M,N,NAs}, Replacement, Rel}, St); no -> St end. @@ -3577,16 +3799,26 @@ obsolete_guard({call,Line,{atom,Lr,F},As}, St0) -> false -> deprecated_function(Line, erlang, F, As, St0); true -> - case is_warn_enabled(obsolete_guard, St0) of - true -> - add_warning(Lr,{obsolete_guard, {F, Arity}}, St0); - false -> - St0 - end + St = case is_warn_enabled(obsolete_guard, St0) of + true -> + add_warning(Lr, {obsolete_guard, {F, Arity}}, St0); + false -> + St0 + end, + test_overriden_by_local(Lr, F, Arity, St) end; obsolete_guard(_G, St) -> St. +test_overriden_by_local(Line, OldTest, Arity, St) -> + ModernTest = list_to_atom("is_"++atom_to_list(OldTest)), + case is_local_function(St#lint.locals, {ModernTest, Arity}) of + true -> + add_error(Line, {obsolete_guard_overridden,OldTest}, St); + false -> + St + end. + %% keyword_warning(Line, Atom, State) -> State. %% Add warning for atoms that will be reserved keywords in the future. %% (Currently, no such keywords to warn for.) @@ -3720,6 +3952,10 @@ extract_sequence(4, [$t, $p | Fmt], Need) -> extract_sequence(5, [$p|Fmt], Need); extract_sequence(4, [$t, $P | Fmt], Need) -> extract_sequence(5, [$P|Fmt], Need); +extract_sequence(4, [$t, $w | Fmt], Need) -> + extract_sequence(5, [$w|Fmt], Need); +extract_sequence(4, [$t, $W | Fmt], Need) -> + extract_sequence(5, [$W|Fmt], Need); extract_sequence(4, [$t, C | _Fmt], _Need) -> {error,"invalid control ~t" ++ [C]}; extract_sequence(4, [$l, $p | Fmt], Need) -> diff --git a/lib/stdlib/src/erl_parse.yrl b/lib/stdlib/src/erl_parse.yrl index e82282421e..6e72d64acc 100644 --- a/lib/stdlib/src/erl_parse.yrl +++ b/lib/stdlib/src/erl_parse.yrl @@ -2,7 +2,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2015. All Rights Reserved. +%% Copyright Ericsson AB 1996-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -33,7 +33,6 @@ list tail list_comprehension lc_expr lc_exprs binary_comprehension tuple -%struct record_expr record_tuple record_field record_fields map_expr map_tuple map_field map_field_assoc map_field_exact map_fields map_key if_expr if_clause if_clauses case_expr cr_clause cr_clauses receive_expr @@ -85,10 +84,6 @@ type_spec -> '(' spec_fun type_sigs ')' : {'$2', '$3'}. spec_fun -> atom : '$1'. spec_fun -> atom ':' atom : {'$1', '$3'}. -%% The following two are retained only for backwards compatibility; -%% they are not part of the EEP syntax and should be removed. -spec_fun -> atom '/' integer '::' : {'$1', '$3'}. -spec_fun -> atom ':' atom '/' integer '::' : {'$1', '$3', '$5'}. typed_attr_val -> expr ',' typed_record_fields : {typed_record, '$1', '$3'}. typed_attr_val -> expr '::' top_type : {type_def, '$1', '$3'}. @@ -112,9 +107,8 @@ type_sig -> fun_type 'when' type_guards : {type, ?anno('$1'), bounded_fun, type_guards -> type_guard : ['$1']. type_guards -> type_guard ',' type_guards : ['$1'|'$3']. -type_guard -> atom '(' top_types ')' : {type, ?anno('$1'), constraint, - ['$1', '$3']}. -type_guard -> var '::' top_type : build_def('$1', '$3'). +type_guard -> atom '(' top_types ')' : build_compat_constraint('$1', '$3'). +type_guard -> var '::' top_type : build_constraint('$1', '$3'). top_types -> top_type : ['$1']. top_types -> top_type ',' top_types : ['$1'|'$3']. @@ -160,6 +154,7 @@ type -> '#' atom '{' field_types '}' : {type, ?anno('$1'), record, ['$2'|'$4']}. type -> binary_type : '$1'. type -> integer : '$1'. +type -> char : '$1'. type -> 'fun' '(' ')' : {type, ?anno('$1'), 'fun', []}. type -> 'fun' '(' fun_type_100 ')' : '$3'. @@ -176,7 +171,11 @@ fun_type -> '(' top_types ')' '->' top_type map_pair_types -> map_pair_type : ['$1']. map_pair_types -> map_pair_type ',' map_pair_types : ['$1'|'$3']. -map_pair_type -> top_type '=>' top_type : {type, ?anno('$2'), map_field_assoc,['$1','$3']}. + +map_pair_type -> top_type '=>' top_type : {type, ?anno('$2'), + map_field_assoc,['$1','$3']}. +map_pair_type -> top_type ':=' top_type : {type, ?anno('$2'), + map_field_exact,['$1','$3']}. field_types -> field_type : ['$1']. field_types -> field_type ',' field_types : ['$1'|'$3']. @@ -268,7 +267,6 @@ expr_max -> binary : '$1'. expr_max -> list_comprehension : '$1'. expr_max -> binary_comprehension : '$1'. expr_max -> tuple : '$1'. -%%expr_max -> struct : '$1'. expr_max -> '(' expr ')' : '$2'. expr_max -> 'begin' exprs 'end' : {block,?anno('$1'),'$2'}. expr_max -> if_expr : '$1'. @@ -315,7 +313,7 @@ bit_size_expr -> expr_max : '$1'. list_comprehension -> '[' expr '||' lc_exprs ']' : {lc,?anno('$1'),'$2','$4'}. -binary_comprehension -> '<<' binary '||' lc_exprs '>>' : +binary_comprehension -> '<<' expr_max '||' lc_exprs '>>' : {bc,?anno('$1'),'$2','$4'}. lc_exprs -> lc_expr : ['$1']. lc_exprs -> lc_expr ',' lc_exprs : ['$1'|'$3']. @@ -327,10 +325,6 @@ lc_expr -> binary '<=' expr : {b_generate,?anno('$2'),'$1','$3'}. tuple -> '{' '}' : {tuple,?anno('$1'),[]}. tuple -> '{' exprs '}' : {tuple,?anno('$1'),'$2'}. - -%%struct -> atom tuple : -%% {struct,?anno('$1'),element(3, '$1'),element(3, '$2')}. - map_expr -> '#' map_tuple : {map, ?anno('$1'),'$2'}. map_expr -> expr_max '#' map_tuple : @@ -516,6 +510,22 @@ comp_op -> '>' : '$1'. comp_op -> '=:=' : '$1'. comp_op -> '=/=' : '$1'. +Header +"%% This file was automatically generated from the file \"erl_parse.yrl\"." +"%%" +"%% Copyright Ericsson AB 1996-2015. All Rights Reserved." +"%%" +"%% Licensed under the Apache License, Version 2.0 (the \"License\"); you may" +"%% not use this file except in compliance with the License. You may obtain" +"%% a copy of the License at <http://www.apache.org/licenses/LICENSE-2.0>" +"%%" +"%% Unless required by applicable law or agreed to in writing, software" +"%% distributed under the License is distributed on an \"AS IS\" BASIS," +"%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied." +"%% See the License for the specific language governing permissions and" +"%% limitations under the License." +"". + Erlang code. -export([parse_form/1,parse_exprs/1,parse_term/1]). @@ -525,23 +535,430 @@ Erlang code. -export([type_inop_prec/1,type_preop_prec/1]). -export([map_anno/2, fold_anno/3, mapfold_anno/3, new_anno/1, anno_to_term/1, anno_from_term/1]). --export([set_line/2,get_attribute/2,get_attributes/1]). - --deprecated([{set_line, 2, next_major_release}, - {get_attribute, 2, next_major_release}, - {get_attributes, 1, next_major_release}]). %% The following directive is needed for (significantly) faster compilation %% of the generated .erl file by the HiPE compiler. Please do not remove. -compile([{hipe,[{regalloc,linear_scan}]}]). -export_type([abstract_clause/0, abstract_expr/0, abstract_form/0, - error_info/0]). + abstract_type/0, form_info/0, error_info/0]). + +%% Start of Abstract Format + +-type anno() :: erl_anno:anno(). + +-type abstract_form() :: af_module() + | af_behavior() + | af_behaviour() + | af_export() + | af_import() + | af_export_type() + | af_compile() + | af_file() + | af_record_decl() + | af_type_decl() + | af_function_spec() + | af_wild_attribute() + | af_function_decl(). + +-type af_module() :: {'attribute', anno(), 'module', module()}. + +-type af_behavior() :: {'attribute', anno(), 'behavior', behaviour()}. + +-type af_behaviour() :: {'attribute', anno(), 'behaviour', behaviour()}. + +-type behaviour() :: atom(). + +-type af_export() :: {'attribute', anno(), 'export', af_fa_list()}. + +-type af_import() :: {'attribute', anno(), 'import', af_fa_list()}. + +-type af_fa_list() :: [{function_name(), arity()}]. + +-type af_export_type() :: {'attribute', anno(), 'export_type', af_ta_list()}. + +-type af_ta_list() :: [{type_name(), arity()}]. + +-type af_compile() :: {'attribute', anno(), 'compile', any()}. + +-type af_file() :: {'attribute', anno(), 'file', {string(), anno()}}. + +-type af_record_decl() :: + {'attribute', anno(), 'record', {record_name(), [af_field_decl()]}}. + +-type af_field_decl() :: af_typed_field() | af_field(). + +-type af_typed_field() :: + {'typed_record_field', af_field(), abstract_type()}. + +-type af_field() :: {'record_field', anno(), af_field_name()} + | {'record_field', anno(), af_field_name(), abstract_expr()}. + +-type af_type_decl() :: {'attribute', anno(), type_attr(), + {type_name(), abstract_type(), [af_variable()]}}. + +-type type_attr() :: 'opaque' | 'type'. + +-type af_function_spec() :: {'attribute', anno(), spec_attr(), + {{function_name(), arity()}, + af_function_type_list()}} + | {'attribute', anno(), 'spec', + {{module(), function_name(), arity()}, + af_function_type_list()}}. + +-type spec_attr() :: 'callback' | 'spec'. + +-type af_wild_attribute() :: {'attribute', anno(), atom(), any()}. + +-type af_function_decl() :: + {'function', anno(), function_name(), arity(), af_clause_seq()}. + +-type abstract_expr() :: af_literal() + | af_match(abstract_expr()) + | af_variable() + | af_tuple(abstract_expr()) + | af_nil() + | af_cons(abstract_expr()) + | af_bin(abstract_expr()) + | af_binary_op(abstract_expr()) + | af_unary_op(abstract_expr()) + | af_record_creation(abstract_expr()) + | af_record_update(abstract_expr()) + | af_record_index() + | af_record_field_access(abstract_expr()) + | af_map_creation(abstract_expr()) + | af_map_update(abstract_expr()) + | af_catch() + | af_local_call() + | af_remote_call() + | af_list_comprehension() + | af_binary_comprehension() + | af_block() + | af_if() + | af_case() + | af_try() + | af_receive() + | af_local_fun() + | af_remote_fun() + | af_fun() + | af_named_fun(). + +-type af_record_update(T) :: {'record', + anno(), + abstract_expr(), + record_name(), + [af_record_field(T)]}. + +-type af_catch() :: {'catch', anno(), abstract_expr()}. + +-type af_local_call() :: {'call', anno(), af_local_function(), af_args()}. + +-type af_remote_call() :: {'call', anno(), af_remote_function(), af_args()}. + +-type af_args() :: [abstract_expr()]. + +-type af_local_function() :: abstract_expr(). + +-type af_remote_function() :: + {'remote', anno(), abstract_expr(), abstract_expr()}. + +-type af_list_comprehension() :: + {'lc', anno(), af_template(), af_qualifier_seq()}. + +-type af_binary_comprehension() :: + {'bc', anno(), af_template(), af_qualifier_seq()}. + +-type af_template() :: abstract_expr(). + +-type af_qualifier_seq() :: [af_qualifier()]. + +-type af_qualifier() :: af_generator() | af_filter(). + +-type af_generator() :: {'generate', anno(), af_pattern(), abstract_expr()} + | {'b_generate', anno(), af_pattern(), abstract_expr()}. + +-type af_filter() :: abstract_expr(). + +-type af_block() :: {'block', anno(), af_body()}. + +-type af_if() :: {'if', anno(), af_clause_seq()}. + +-type af_case() :: {'case', anno(), abstract_expr(), af_clause_seq()}. + +-type af_try() :: {'try', + anno(), + af_body() | [], + af_clause_seq() | [], + af_clause_seq() | [], + af_body() | []}. + +-type af_clause_seq() :: [af_clause(), ...]. + +-type af_receive() :: + {'receive', anno(), af_clause_seq()} + | {'receive', anno(), af_clause_seq(), abstract_expr(), af_body()}. + +-type af_local_fun() :: + {'fun', anno(), {'function', function_name(), arity()}}. + +-type af_remote_fun() :: + {'fun', anno(), {'function', module(), function_name(), arity()}} + | {'fun', anno(), {'function', af_atom(), af_atom(), af_integer()}}. + +-type af_fun() :: {'fun', anno(), {'clauses', af_clause_seq()}}. + +-type af_named_fun() :: {'named_fun', anno(), fun_name(), af_clause_seq()}. + +-type fun_name() :: atom(). + +-type abstract_clause() :: af_clause(). + +-type af_clause() :: + {'clause', anno(), [af_pattern()], af_guard_seq(), af_body()}. + +-type af_body() :: [abstract_expr(), ...]. + +-type af_guard_seq() :: [af_guard()]. + +-type af_guard() :: [af_guard_test(), ...]. + +-type af_guard_test() :: af_literal() + | af_variable() + | af_tuple(af_guard_test()) + | af_nil() + | af_cons(af_guard_test()) + | af_bin(af_guard_test()) + | af_binary_op(af_guard_test()) + | af_unary_op(af_guard_test()) + | af_record_creation(af_guard_test()) + | af_record_index() + | af_record_field_access(af_guard_test()) + | af_map_creation(abstract_expr()) + | af_map_update(abstract_expr()) + | af_guard_call() + | af_remote_guard_call(). + +-type af_record_field_access(T) :: + {'record_field', anno(), T, record_name(), af_field_name()}. + +-type af_map_creation(T) :: {'map', anno(), [af_assoc(T)]}. + +-type af_map_update(T) :: {'map', anno(), T, [af_assoc(T)]}. + +-type af_assoc(T) :: {'map_field_assoc', anno(), T, T} + | af_assoc_exact(T). + +-type af_assoc_exact(T) :: {'map_field_exact', anno(), T, T}. + +-type af_guard_call() :: {'call', anno(), function_name(), [af_guard_test()]}. + +-type af_remote_guard_call() :: + {'call', anno(), + {'remote', anno(), af_lit_atom('erlang'), af_atom()}, + [af_guard_test()]}. + +-type af_pattern() :: af_literal() + | af_match(af_pattern()) + | af_variable() + | af_tuple(af_pattern()) + | af_nil() + | af_cons(af_pattern()) + | af_bin(af_pattern()) + | af_binary_op(af_pattern()) + | af_unary_op(af_pattern()) + | af_record_creation(af_pattern()) + | af_record_index() + | af_map_pattern(). + +-type af_record_index() :: + {'record_index', anno(), record_name(), af_field_name()}. + +-type af_record_creation(T) :: + {'record', anno(), record_name(), [af_record_field(T)]}. + +-type af_record_field(T) :: {'record_field', anno(), af_field_name(), T}. + +-type af_map_pattern() :: + {'map', anno(), [af_assoc_exact(abstract_expr)]}. + +-type abstract_type() :: af_annotated_type() + | af_atom() + | af_bitstring_type() + | af_empty_list_type() + | af_fun_type() + | af_integer_range_type() + | af_map_type() + | af_predefined_type() + | af_record_type() + | af_remote_type() + | af_singleton_integer_type() + | af_tuple_type() + | af_type_union() + | af_type_variable() + | af_user_defined_type(). + +-type af_annotated_type() :: + {'ann_type', anno(), [af_anno() | abstract_type()]}. % [Var, Type] + +-type af_anno() :: af_variable(). + +-type af_bitstring_type() :: + {'type', anno(), 'binary', [af_singleton_integer_type()]}. + +-type af_empty_list_type() :: {'type', anno(), 'nil', []}. + +-type af_fun_type() :: {'type', anno(), 'fun', []} + | {'type', anno(), 'fun', [{'type', anno(), 'any'} | + abstract_type()]} + | {'type', anno(), 'fun', af_function_type()}. + +-type af_integer_range_type() :: + {'type', anno(), 'range', [af_singleton_integer_type()]}. + +-type af_map_type() :: {'type', anno(), 'map', 'any'} + | {'type', anno(), 'map', [af_assoc_type()]}. + +-type af_assoc_type() :: + {'type', anno(), 'map_field_assoc', [abstract_type()]} + | {'type', anno(), 'map_field_exact', [abstract_type()]}. + +-type af_predefined_type() :: + {'type', anno(), type_name(), [abstract_type()]}. + +-type af_record_type() :: + {'type', anno(), 'record', [(Name :: af_atom()) % [Name, T1, ... Tk] + | af_record_field_type()]}. + +-type af_record_field_type() :: + {'type', anno(), 'field_type', [(Name :: af_atom()) | + abstract_type()]}. % [Name, Type] + +-type af_remote_type() :: + {'remote_type', anno(), [(Module :: af_atom()) | + (TypeName :: af_atom()) | + [abstract_type()]]}. % [Module, Name, [T]] + +-type af_tuple_type() :: {'type', anno(), 'tuple', 'any'} + | {'type', anno(), 'tuple', [abstract_type()]}. + +-type af_type_union() :: {'type', anno(), 'union', [abstract_type()]}. + +-type af_type_variable() :: {'var', anno(), atom()}. % except '_' + +-type af_user_defined_type() :: + {'user_type', anno(), type_name(), [abstract_type()]}. + +-type af_function_type_list() :: [af_constrained_function_type() | + af_function_type()]. + +-type af_constrained_function_type() :: + {'type', anno(), 'bounded_fun', [af_function_type() | % [Ft, Fc] + af_function_constraint()]}. + +-type af_function_type() :: + {'type', anno(), 'fun', + [{'type', anno(), 'product', [abstract_type()]} | abstract_type()]}. + +-type af_function_constraint() :: [af_constraint()]. + +-type af_constraint() :: {'type', anno(), 'constraint', + af_lit_atom('is_subtype'), + [af_type_variable() | abstract_type()]}. % [V, T] + +-type af_singleton_integer_type() :: af_integer() + | af_unary_op(af_singleton_integer_type()) + | af_binary_op(af_singleton_integer_type()). + +-type af_literal() :: af_atom() + | af_character() + | af_float() + | af_integer() + | af_string(). + +-type af_atom() :: af_lit_atom(atom()). + +-type af_lit_atom(A) :: {'atom', anno(), A}. + +-type af_character() :: {'char', anno(), char()}. + +-type af_float() :: {'float', anno(), float()}. + +-type af_integer() :: {'integer', anno(), non_neg_integer()}. + +-type af_string() :: {'string', anno(), string()}. + +-type af_match(T) :: {'match', anno(), af_pattern(), T}. + +-type af_variable() :: {'var', anno(), atom()}. % | af_anon_variable() + +%-type af_anon_variable() :: {'var', anno(), '_'}. + +-type af_tuple(T) :: {'tuple', anno(), [T]}. + +-type af_nil() :: {'nil', anno()}. + +-type af_cons(T) :: {'cons', anno(), T, T}. + +-type af_bin(T) :: {'bin', anno(), [af_binelement(T)]}. + +-type af_binelement(T) :: {'bin_element', + anno(), + T, + af_binelement_size(), + type_specifier_list()}. + +-type af_binelement_size() :: 'default' | abstract_expr(). + +-type af_binary_op(T) :: {'op', anno(), binary_op(), T, T}. + +-type binary_op() :: '/' | '*' | 'div' | 'rem' | 'band' | 'and' | '+' | '-' + | 'bor' | 'bxor' | 'bsl' | 'bsr' | 'or' | 'xor' | '++' + | '--' | '==' | '/=' | '=<' | '<' | '>=' | '>' | '=:=' + | '=/='. + +-type af_unary_op(T) :: {'op', anno(), unary_op(), T}. + +-type unary_op() :: '+' | '*' | 'bnot' | 'not'. + +%% See also lib/stdlib/{src/erl_bits.erl,include/erl_bits.hrl}. +-type type_specifier_list() :: 'default' | [type_specifier(), ...]. + +-type type_specifier() :: type() + | signedness() + | endianness() + | unit(). + +-type type() :: 'integer' + | 'float' + | 'binary' + | 'bytes' + | 'bitstring' + | 'bits' + | 'utf8' + | 'utf16' + | 'utf32'. + +-type signedness() :: 'signed' | 'unsigned'. + +-type endianness() :: 'big' | 'little' | 'native'. + +-type unit() :: {'unit', 1..256}. + +-type record_name() :: atom(). + +-type af_field_name() :: af_atom(). + +-type function_name() :: atom(). + +-type type_name() :: atom(). + +-type form_info() :: {'eof', erl_anno:line()} + | {'error', erl_scan:error_info() | error_info()} + | {'warning', erl_scan:error_info() | error_info()}. + +%% End of Abstract Format %% XXX. To be refined. --type abstract_clause() :: term(). --type abstract_expr() :: term(). --type abstract_form() :: term(). -type error_description() :: term(). -type error_info() :: {erl_anno:line(), module(), error_description()}. -type token() :: erl_scan:token(). @@ -564,6 +981,16 @@ Erlang code. %% keep track of annotation info in tokens -define(anno(Tup), element(2, Tup)). +%-define(DEBUG, true). + +-ifdef(DEBUG). +%% Assumes that erl_anno has been compiled with DEBUG=true. +-define(ANNO_CHECK(Tokens), + [] = [T || T <- Tokens, not is_list(element(2, T))]). +-else. +-define(ANNO_CHECK(Tokens), ok). +-endif. + %% Entry points compatible to old erl_parse. %% These really suck and are only here until Calle gets multiple %% entry points working. @@ -573,10 +1000,15 @@ Erlang code. AbsForm :: abstract_form(), ErrorInfo :: error_info(). parse_form([{'-',A1},{atom,A2,spec}|Tokens]) -> - parse([{'-',A1},{'spec',A2}|Tokens]); + NewTokens = [{'-',A1},{'spec',A2}|Tokens], + ?ANNO_CHECK(NewTokens), + parse(NewTokens); parse_form([{'-',A1},{atom,A2,callback}|Tokens]) -> - parse([{'-',A1},{'callback',A2}|Tokens]); + NewTokens = [{'-',A1},{'callback',A2}|Tokens], + ?ANNO_CHECK(NewTokens), + parse(NewTokens); parse_form(Tokens) -> + ?ANNO_CHECK(Tokens), parse(Tokens). -spec parse_exprs(Tokens) -> {ok, ExprList} | {error, ErrorInfo} when @@ -584,6 +1016,7 @@ parse_form(Tokens) -> ExprList :: [abstract_expr()], ErrorInfo :: error_info(). parse_exprs(Tokens) -> + ?ANNO_CHECK(Tokens), A = erl_anno:new(0), case parse([{atom,A,f},{'(',A},{')',A},{'->',A}|Tokens]) of {ok,{function,_Lf,f,0,[{clause,_Lc,[],[],Exprs}]}} -> @@ -596,6 +1029,7 @@ parse_exprs(Tokens) -> Term :: term(), ErrorInfo :: error_info(). parse_term(Tokens) -> + ?ANNO_CHECK(Tokens), A = erl_anno:new(0), case parse([{atom,A,f},{'(',A},{')',A},{'->',A}|Tokens]) of {ok,{function,_Af,f,0,[{clause,_Ac,[],[],[Expr]}]}} -> @@ -618,6 +1052,9 @@ build_typed_attribute({atom,Aa,record}, build_typed_attribute({atom,Aa,Attr}, {type_def, {call,_,{atom,_,TypeName},Args}, Type}) when Attr =:= 'type' ; Attr =:= 'opaque' -> + lists:foreach(fun({var, A, '_'}) -> ret_err(A, "bad type variable"); + (_) -> ok + end, Args), case lists:all(fun({var, _, _}) -> true; (_) -> false end, Args) of @@ -633,20 +1070,14 @@ build_typed_attribute({atom,Aa,Attr},_) -> end. build_type_spec({Kind,Aa}, {SpecFun, TypeSpecs}) - when (Kind =:= spec) or (Kind =:= callback) -> + when Kind =:= spec ; Kind =:= callback -> NewSpecFun = case SpecFun of {atom, _, Fun} -> {Fun, find_arity_from_specs(TypeSpecs)}; - {{atom,_, Mod}, {atom,_, Fun}} -> - {Mod,Fun,find_arity_from_specs(TypeSpecs)}; - {{atom, _, Fun}, {integer, _, Arity}} -> - %% Old style spec. Allow this for now. - {Fun,Arity}; - {{atom,_, Mod}, {atom, _, Fun}, {integer, _, Arity}} -> - %% Old style spec. Allow this for now. - {Mod,Fun,Arity} - end, + {{atom, _, Mod}, {atom, _, Fun}} -> + {Mod, Fun, find_arity_from_specs(TypeSpecs)} + end, {attribute,Aa,Kind,{NewSpecFun, TypeSpecs}}. find_arity_from_specs([Spec|_]) -> @@ -659,11 +1090,24 @@ find_arity_from_specs([Spec|_]) -> {type, _, 'fun', [{type, _, product, Args},_]} = Fun, length(Args). -build_def({var, A, '_'}, _Types) -> +%% The 'is_subtype(V, T)' syntax is not supported as of Erlang/OTP +%% 19.0, but is kept for backward compatibility. +build_compat_constraint({atom, _, is_subtype}, [{var, _, _}=LHS, Type]) -> + build_constraint(LHS, Type); +build_compat_constraint({atom, _, is_subtype}, [LHS, _Type]) -> + ret_err(?anno(LHS), "bad type variable"); +build_compat_constraint({atom, A, Atom}, _Types) -> + ret_err(A, io_lib:format("unsupported constraint ~tw", [Atom])). + +build_constraint({atom, _, is_subtype}, [{var, _, _}=LHS, Type]) -> + build_constraint(LHS, Type); +build_constraint({atom, A, Atom}, _Foo) -> + ret_err(A, io_lib:format("unsupported constraint ~tw", [Atom])); +build_constraint({var, A, '_'}, _Types) -> ret_err(A, "bad type variable"); -build_def(LHS, Types) -> +build_constraint(LHS, Type) -> IsSubType = {atom, ?anno(LHS), is_subtype}, - {type, ?anno(LHS), constraint, [IsSubType, [LHS, Types]]}. + {type, ?anno(LHS), constraint, [IsSubType, [LHS, Type]]}. lift_unions(T1, {type, _Aa, union, List}) -> {type, ?anno(T1), union, [T1|List]}; @@ -776,7 +1220,7 @@ attribute_farity_map(Args) -> -spec error_bad_decl(erl_anno:anno(), attributes()) -> no_return(). error_bad_decl(Anno, S) -> - ret_err(Anno, io_lib:format("bad ~w declaration", [S])). + ret_err(Anno, io_lib:format("bad ~tw declaration", [S])). farity_list({cons,_Ac,{op,_Ao,'/',{atom,_Aa,A},{integer,_Ai,I}},Tail}) -> [{A,I}|farity_list(Tail)]; @@ -795,31 +1239,11 @@ record_fields([{match,_Am,{atom,Aa,A},Expr}|Fields]) -> [{record_field,Aa,{atom,Aa,A},Expr}|record_fields(Fields)]; record_fields([{typed,Expr,TypeInfo}|Fields]) -> [Field] = record_fields([Expr]), - TypeInfo1 = - case Expr of - {match, _, _, _} -> TypeInfo; %% If we have an initializer. - {atom, Aa, _} -> - case has_undefined(TypeInfo) of - false -> - lift_unions(abstract2(undefined, Aa), TypeInfo); - true -> - TypeInfo - end - end, - [{typed_record_field,Field,TypeInfo1}|record_fields(Fields)]; + [{typed_record_field,Field,TypeInfo}|record_fields(Fields)]; record_fields([Other|_Fields]) -> ret_err(?anno(Other), "bad record field"); record_fields([]) -> []. -has_undefined({atom,_,undefined}) -> - true; -has_undefined({ann_type,_,[_,T]}) -> - has_undefined(T); -has_undefined({type,_,union,Ts}) -> - lists:any(fun has_undefined/1, Ts); -has_undefined(_) -> - false. - term(Expr) -> try normalise(Expr) catch _:_R -> ret_err(?anno(Expr), "bad attribute") @@ -1118,47 +1542,31 @@ type_preop_prec('-') -> {600,700}; type_preop_prec('bnot') -> {600,700}; type_preop_prec('#') -> {700,800}. -%%% [Experimental]. The parser just copies the attributes of the -%%% scanner tokens to the abstract format. This design decision has -%%% been hidden to some extent: use set_line() and get_attribute() to -%%% access the second element of (almost all) of the abstract format -%%% tuples. A typical use is to negate line numbers to prevent the -%%% compiler from emitting warnings and errors. The second element can -%%% (of course) be set to any value, but then these functions no -%%% longer apply. To get all present attributes as a property list -%%% get_attributes() should be used. - --compile({nowarn_deprecated_function,{erl_scan,set_attribute,3}}). -set_line(L, F) -> - erl_scan:set_attribute(line, L, F). - --compile({nowarn_deprecated_function,{erl_scan,attributes_info,2}}). -get_attribute(L, Name) -> - erl_scan:attributes_info(L, Name). - --compile({nowarn_deprecated_function,{erl_scan,attributes_info,1}}). -get_attributes(L) -> - erl_scan:attributes_info(L). +-type erl_parse_tree() :: abstract_clause() + | abstract_expr() + | abstract_form() + | abstract_type(). -spec map_anno(Fun, Abstr) -> NewAbstr when - Fun :: fun((Anno) -> Anno), + Fun :: fun((Anno) -> NewAnno), Anno :: erl_anno:anno(), - Abstr :: abstract_form() | abstract_expr(), - NewAbstr :: abstract_form() | abstract_expr(). + NewAnno :: erl_anno:anno(), + Abstr :: erl_parse_tree() | form_info(), + NewAbstr :: erl_parse_tree() | form_info(). map_anno(F0, Abstr) -> F = fun(A, Acc) -> {F0(A), Acc} end, {NewAbstr, []} = modify_anno1(Abstr, [], F), NewAbstr. --spec fold_anno(Fun, Acc0, Abstr) -> NewAbstr when +-spec fold_anno(Fun, Acc0, Abstr) -> Acc1 when Fun :: fun((Anno, AccIn) -> AccOut), Anno :: erl_anno:anno(), Acc0 :: term(), + Acc1 :: term(), AccIn :: term(), AccOut :: term(), - Abstr :: abstract_form() | abstract_expr(), - NewAbstr :: abstract_form() | abstract_expr(). + Abstr :: erl_parse_tree() | form_info(). fold_anno(F0, Acc0, Abstr) -> F = fun(A, Acc) -> {A, F0(A, Acc)} end, @@ -1166,51 +1574,45 @@ fold_anno(F0, Acc0, Abstr) -> NewAcc. -spec mapfold_anno(Fun, Acc0, Abstr) -> {NewAbstr, Acc1} when - Fun :: fun((Anno, AccIn) -> {Anno, AccOut}), + Fun :: fun((Anno, AccIn) -> {NewAnno, AccOut}), Anno :: erl_anno:anno(), + NewAnno :: erl_anno:anno(), Acc0 :: term(), Acc1 :: term(), AccIn :: term(), AccOut :: term(), - Abstr :: abstract_form() | abstract_expr(), - NewAbstr :: abstract_form() | abstract_expr(). + Abstr :: erl_parse_tree() | form_info(), + NewAbstr :: erl_parse_tree() | form_info(). mapfold_anno(F, Acc0, Abstr) -> modify_anno1(Abstr, Acc0, F). -spec new_anno(Term) -> Abstr when Term :: term(), - Abstr :: abstract_form() | abstract_expr(). + Abstr :: erl_parse_tree() | form_info(). new_anno(Term) -> - map_anno(fun erl_anno:new/1, Term). + F = fun(L, Acc) -> {erl_anno:new(L), Acc} end, + {NewAbstr, []} = modify_anno1(Term, [], F), + NewAbstr. -spec anno_to_term(Abstr) -> term() when - Abstr :: abstract_form() | abstract_expr(). + Abstr :: erl_parse_tree() | form_info(). anno_to_term(Abstract) -> - map_anno(fun erl_anno:to_term/1, Abstract). + F = fun(Anno, Acc) -> {erl_anno:to_term(Anno), Acc} end, + {NewAbstract, []} = modify_anno1(Abstract, [], F), + NewAbstract. --spec anno_from_term(Term) -> abstract_form() | abstract_expr() when +-spec anno_from_term(Term) -> erl_parse_tree() | form_info() when Term :: term(). anno_from_term(Term) -> - map_anno(fun erl_anno:from_term/1, Term). + F = fun(T, Acc) -> {erl_anno:from_term(T), Acc} end, + {NewTerm, []} = modify_anno1(Term, [], F), + NewTerm. %% Forms. -%% Recognize what sys_pre_expand does: -modify_anno1({'fun',A,F,{_,_,_}=Id}, Ac, Mf) -> - {A1,Ac1} = Mf(A, Ac), - {F1,Ac2} = modify_anno1(F, Ac1, Mf), - {{'fun',A1,F1,Id},Ac2}; -modify_anno1({named_fun,A,N,F,{_,_,_}=Id}, Ac, Mf) -> - {A1,Ac1} = Mf(A, Ac), - {F1,Ac2} = modify_anno1(F, Ac1, Mf), - {{named_fun,A1,N,F1,Id},Ac2}; -modify_anno1({attribute,A,N,[V]}, Ac, Mf) -> - {{attribute,A1,N1,V1},Ac1} = modify_anno1({attribute,A,N,V}, Ac, Mf), - {{attribute,A1,N1,[V1]},Ac1}; -%% End of sys_pre_expand special forms. modify_anno1({function,F,A}, Ac, _Mf) -> {{function,F,A},Ac}; modify_anno1({function,M,F,A}, Ac, Mf) -> @@ -1247,6 +1649,8 @@ modify_anno1({warning,W}, Ac, _Mf) -> {{warning,W},Ac}; modify_anno1({error,W}, Ac, _Mf) -> {{error,W},Ac}; +modify_anno1({eof,L}, Ac, _Mf) -> + {{eof,L},Ac}; %% Expressions. modify_anno1({clauses,Cs}, Ac, Mf) -> {Cs1,Ac1} = modify_anno1(Cs, Ac, Mf), diff --git a/lib/stdlib/src/erl_posix_msg.erl b/lib/stdlib/src/erl_posix_msg.erl index 5eac230631..bfafca1ff7 100644 --- a/lib/stdlib/src/erl_posix_msg.erl +++ b/lib/stdlib/src/erl_posix_msg.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1997-2010. All Rights Reserved. +%% Copyright Ericsson AB 1997-2016. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. diff --git a/lib/stdlib/src/erl_pp.erl b/lib/stdlib/src/erl_pp.erl index f7a969977a..ee5e7a11bf 100644 --- a/lib/stdlib/src/erl_pp.erl +++ b/lib/stdlib/src/erl_pp.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2015. All Rights Reserved. +%% Copyright Ericsson AB 1996-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -44,13 +44,22 @@ | {encoding, latin1 | unicode | utf8}). -type(options() :: hook_function() | [option()]). --record(pp, {string_fun, char_fun}). +-record(pp, {value_fun, string_fun, char_fun}). -record(options, {hook, encoding, opts}). %-define(DEBUG, true). -ifdef(DEBUG). +-define(FORM_TEST(T), + _ = case T of + {eof, _Line} -> ok; + {warning, _W} -> ok; + {error, _E} -> ok; + _ -> ?TEST(T) + end). +-define(EXPRS_TEST(L), + [?TEST(E) || E <- L]). -define(TEST(T), %% Assumes that erl_anno has been compiled with DEBUG=true. %% erl_pp does not use the annoations, but test it anyway. @@ -62,6 +71,8 @@ erlang:error(badarg, [T]) end). -else. +-define(FORM_TEST(T), ok). +-define(EXPRS_TEST(T), ok). -define(TEST(T), ok). -endif. @@ -70,19 +81,19 @@ %%% -spec(form(Form) -> io_lib:chars() when - Form :: erl_parse:abstract_form()). + Form :: erl_parse:abstract_form() | erl_parse:form_info()). form(Thing) -> form(Thing, none). -spec(form(Form, Options) -> io_lib:chars() when - Form :: erl_parse:abstract_form(), + Form :: erl_parse:abstract_form() | erl_parse:form_info(), Options :: options()). form(Thing, Options) -> - ?TEST(Thing), + ?FORM_TEST(Thing), State = state(Options), - frmt(lform(Thing, options(Options), State), State). + frmt(lform(Thing, options(Options)), State). -spec(attribute(Attribute) -> io_lib:chars() when Attribute :: erl_parse:abstract_form()). @@ -97,7 +108,7 @@ attribute(Thing) -> attribute(Thing, Options) -> ?TEST(Thing), State = state(Options), - frmt(lattribute(Thing, options(Options), State), State). + frmt(lattribute(Thing, options(Options)), State). -spec(function(Function) -> io_lib:chars() when Function :: erl_parse:abstract_form()). @@ -124,7 +135,7 @@ guard(Gs) -> Options :: options()). guard(Gs, Options) -> - ?TEST(Gs), + ?EXPRS_TEST(Gs), frmt(lguard(Gs, options(Options)), state(Options)). -spec(exprs(Expressions) -> io_lib:chars() when @@ -146,7 +157,7 @@ exprs(Es, Options) -> Options :: options()). exprs(Es, I, Options) -> - ?TEST(Es), + ?EXPRS_TEST(Es), frmt({seq,[],[],[$,],lexprs(Es, options(Options))}, I, state(Options)). -spec(expr(Expression) -> io_lib:chars() when @@ -203,11 +214,15 @@ state(_Hook) -> state(). state() -> - #pp{string_fun = fun io_lib:write_string_as_latin1/1, + Options = [{encoding,latin1}], + #pp{value_fun = fun(V) -> io_lib_pretty:print(V, Options) end, + string_fun = fun io_lib:write_string_as_latin1/1, char_fun = fun io_lib:write_char_as_latin1/1}. unicode_state() -> - #pp{string_fun = fun io_lib:write_string/1, + Options = [{encoding,unicode}], + #pp{value_fun = fun(V) -> io_lib_pretty:print(V, Options) end, + string_fun = fun io_lib:write_string/1, char_fun = fun io_lib:write_char/1}. encoding(Options) -> @@ -217,54 +232,55 @@ encoding(Options) -> unicode -> unicode end. -lform({attribute,Line,Name,Arg}, Opts, State) -> - lattribute({attribute,Line,Name,Arg}, Opts, State); -lform({function,Line,Name,Arity,Clauses}, Opts, _State) -> +lform({attribute,Line,Name,Arg}, Opts) -> + lattribute({attribute,Line,Name,Arg}, Opts); +lform({function,Line,Name,Arity,Clauses}, Opts) -> lfunction({function,Line,Name,Arity,Clauses}, Opts); %% These are specials to make it easier for the compiler. -lform({error,E}, _Opts, _State) -> +lform({error,E}, _Opts) -> leaf(format("~p\n", [{error,E}])); -lform({warning,W}, _Opts, _State) -> +lform({warning,W}, _Opts) -> leaf(format("~p\n", [{warning,W}])); -lform({eof,_Line}, _Opts, _State) -> +lform({eof,_Line}, _Opts) -> $\n. -lattribute({attribute,_Line,type,Type}, Opts, _State) -> +lattribute({attribute,_Line,type,Type}, Opts) -> [typeattr(type, Type, Opts),leaf(".\n")]; -lattribute({attribute,_Line,opaque,Type}, Opts, _State) -> +lattribute({attribute,_Line,opaque,Type}, Opts) -> [typeattr(opaque, Type, Opts),leaf(".\n")]; -lattribute({attribute,_Line,spec,Arg}, _Opts, _State) -> +lattribute({attribute,_Line,spec,Arg}, _Opts) -> [specattr(spec, Arg),leaf(".\n")]; -lattribute({attribute,_Line,callback,Arg}, _Opts, _State) -> +lattribute({attribute,_Line,callback,Arg}, _Opts) -> [specattr(callback, Arg),leaf(".\n")]; -lattribute({attribute,_Line,Name,Arg}, Opts, State) -> - [lattribute(Name, Arg, Opts, State),leaf(".\n")]. +lattribute({attribute,_Line,Name,Arg}, Opts) -> + [lattribute(Name, Arg, Opts),leaf(".\n")]. -lattribute(module, {M,Vs}, _Opts, _State) -> +lattribute(module, {M,Vs}, _Opts) -> A = a0(), - attr("module",[{var,A,pname(M)}, - foldr(fun(V, C) -> {cons,A,{var,A,V},C} - end, {nil,A}, Vs)]); -lattribute(module, M, _Opts, _State) -> - attr("module", [{var,a0(),pname(M)}]); -lattribute(export, Falist, _Opts, _State) -> - call({var,a0(),"-export"}, [falist(Falist)], 0, options(none)); -lattribute(import, Name, _Opts, _State) when is_list(Name) -> - attr("import", [{var,a0(),pname(Name)}]); -lattribute(import, {From,Falist}, _Opts, _State) -> - attr("import",[{var,a0(),pname(From)},falist(Falist)]); -lattribute(optional_callbacks, Falist, Opts, _State) -> - ArgL = try falist(Falist) - catch _:_ -> abstract(Falist, Opts) - end, - call({var,a0(),"-optional_callbacks"}, [ArgL], 0, options(none)); -lattribute(file, {Name,Line}, _Opts, State) -> - attr("file", [{var,a0(),(State#pp.string_fun)(Name)},{integer,a0(),Line}]); -lattribute(record, {Name,Is}, Opts, _State) -> - Nl = leaf(format("-record(~w,", [Name])), + attr(module,[{var,A,pname(M)}, + foldr(fun(V, C) -> {cons,A,{var,A,V},C} + end, {nil,A}, Vs)]); +lattribute(module, M, _Opts) -> + attr(module, [{var,a0(),pname(M)}]); +lattribute(export, Falist, _Opts) -> + attrib(export, falist(Falist)); +lattribute(import, Name, _Opts) when is_list(Name) -> + attr(import, [{var,a0(),pname(Name)}]); +lattribute(import, {From,Falist}, _Opts) -> + attrib(import, [leaf(pname(From)),falist(Falist)]); +lattribute(export_type, Talist, _Opts) -> + attrib(export_type, falist(Talist)); +lattribute(optional_callbacks, Falist, Opts) -> + try attrib(optional_callbacks, falist(Falist)) + catch _:_ -> attr(optional_callbacks, [abstract(Falist, Opts)]) + end; +lattribute(file, {Name,Line}, _Opts) -> + attr(file, [{string,a0(),Name},{integer,a0(),Line}]); +lattribute(record, {Name,Is}, Opts) -> + Nl = [leaf("-record("),{atom,Name},$,], [{first,Nl,record_fields(Is, Opts)},$)]; -lattribute(Name, Arg, Options, _State) -> - attr(write(Name), [abstract(Arg, Options)]). +lattribute(Name, Arg, Options) -> + attr(Name, [abstract(Arg, Options)]). abstract(Arg, #options{encoding = Encoding}) -> erl_parse:abstract(Arg, [{encoding,Encoding}]). @@ -321,14 +337,13 @@ ltype({type,_,'fun',[{type,_,any},_]}=FunType, _) -> ltype({type,_Line,'fun',[{type,_,product,_},_]}=FunType, _) -> [fun_type(['fun',$(], FunType),$)]; ltype({type,Line,T,Ts}, _) -> - %% Compatibility. Before 18.0. simple_type({atom,Line,T}, Ts); ltype({user_type,Line,T,Ts}, _) -> simple_type({atom,Line,T}, Ts); ltype({remote_type,Line,[M,F,Ts]}, _) -> simple_type({remote,Line,M,F}, Ts); ltype({atom,_,T}, _) -> - leaf(write(T)); + {atom,T}; ltype(E, P) -> lexpr(E, P, options(none)). @@ -346,16 +361,10 @@ map_type(Fs) -> map_pair_types(Fs) -> tuple_type(Fs, fun map_pair_type/2). -map_pair_type({type,_Line,map_field_assoc,[Ktype,Vtype]}, Prec) -> - map_assoc_typed(ltype(Ktype), Vtype, Prec). - -map_assoc_typed(B, {type,_,union,Ts}, Prec) -> - {first,[B,$\s],{seq,[],[],[],map_assoc_union_type(Ts, Prec)}}; -map_assoc_typed(B, Type, Prec) -> - {list,[{cstep,[B," =>"],ltype(Type, Prec)}]}. - -map_assoc_union_type([T|Ts], Prec) -> - [[leaf("=> "),ltype(T)] | ltypes(Ts, fun union_elem/2, Prec)]. +map_pair_type({type,_Line,map_field_assoc,[KType,VType]}, Prec) -> + {list,[{cstep,[ltype(KType, Prec),leaf(" =>")],ltype(VType, Prec)}]}; +map_pair_type({type,_Line,map_field_exact,[KType,VType]}, Prec) -> + {list,[{cstep,[ltype(KType, Prec),leaf(" :=")],ltype(VType, Prec)}]}. record_type(Name, Fields) -> {first,[record_name(Name)],field_types(Fields)}. @@ -370,21 +379,18 @@ typed(B, Type) -> {_L,_P,R} = type_inop_prec('::'), {list,[{cstep,[B,' ::'],ltype(Type, R)}]}. -union_elem(T, Prec) -> - [leaf(" | "),ltype(T, Prec)]. - tuple_type(Ts, F) -> {seq,${,$},[$,],ltypes(Ts, F, 0)}. specattr(SpecKind, {FuncSpec,TypeSpecs}) -> Func = case FuncSpec of {F,_A} -> - format("~w", [F]); + {atom,F}; {M,F,_A} -> - format("~w:~w", [M, F]) + [{atom,M},$:,{atom,F}] end, {first,leaf(lists:concat(["-", SpecKind, " "])), - {list,[{first,leaf(Func),spec_clauses(TypeSpecs)}]}}. + {list,[{first,Func,spec_clauses(TypeSpecs)}]}}. spec_clauses(TypeSpecs) -> {prefer_nl,[$;],[sig_type(T) || T <- TypeSpecs]}. @@ -399,6 +405,9 @@ guard_type(Before, Gs) -> Gl = {list,[{step,'when',expr_list(Gs, [$,], fun constraint/2, Opts)}]}, {list,[{step,Before,Gl}]}. +constraint({type,_Line,constraint,[{atom,_,is_subtype},[{var,_,_}=V,Type]]}, + _Opts) -> + typed(lexpr(V, options(none)), Type); constraint({type,_Line,constraint,[Tag,As]}, _Opts) -> simple_type(Tag, As). @@ -423,7 +432,10 @@ ltypes(Ts, F, Prec) -> [F(T, Prec) || T <- Ts]. attr(Name, Args) -> - call({var,a0(),format("-~s", [Name])}, Args, 0, options(none)). + {first,[$-,{atom,Name}],args(Args, options(none))}. + +attrib(Name, Args) -> + {first,[$-,{atom,Name}],[{seq,$(,$),[$,],Args}]}. pname(['' | As]) -> [$. | pname(As)]; @@ -435,10 +447,13 @@ pname(A) when is_atom(A) -> write(A). falist([]) -> - {nil,a0()}; -falist([{Name,Arity}|Falist]) -> - A = a0(), - {cons,A,{var,A,format("~w/~w", [Name,Arity])},falist(Falist)}. + [leaf("[]")]; +falist(Falist) -> + L = [begin + {Name,Arity} = Fa, + [{atom,Name},leaf(format("/~w", [Arity]))] + end || Fa <- Falist], + [{seq,$[,$],$,,L}]. lfunction({function,_Line,Name,_Arity,Cs}, Opts) -> Cll = nl_clauses(fun (C, H) -> func_clause(Name, C, H) end, $;, Opts, Cs), @@ -483,7 +498,7 @@ lexpr({var,_,V}, _, _) -> leaf(format("~ts", [V])); lexpr({char,_,C}, _, _) -> {char,C}; lexpr({integer,_,N}, _, _) -> leaf(write(N)); lexpr({float,_,F}, _, _) -> leaf(write(F)); -lexpr({atom,_,A}, _, _) -> leaf(write(A)); +lexpr({atom,_,A}, _, _) -> {atom,A}; lexpr({string,_,S}, _, _) -> {string,S}; lexpr({nil,_}, _, _) -> '[]'; lexpr({cons,_,H,T}, _, Opts) -> @@ -513,7 +528,7 @@ lexpr({record, _, Name, Fs}, Prec, Opts) -> lexpr({record_field, _, Rec, Name, F}, Prec, Opts) -> {L,P,R} = inop_prec('#'), Rl = lexpr(Rec, L, Opts), - Nl = leaf(format("#~w.", [Name])), + Nl = [$#,{atom,Name},$.], El = [Rl,Nl,lexpr(F, R, Opts)], maybe_paren(P, Prec, El); lexpr({record, _, Rec, Name, Fs}, Prec, Opts) -> @@ -532,12 +547,12 @@ lexpr({record_field, _, Rec, F}, Prec, Opts) -> maybe_paren(P, Prec, El); lexpr({map, _, Fs}, Prec, Opts) -> {P,_R} = preop_prec('#'), - El = {first,leaf("#"),map_fields(Fs, Opts)}, + El = {first,$#,map_fields(Fs, Opts)}, maybe_paren(P, Prec, El); lexpr({map, _, Map, Fs}, Prec, Opts) -> {L,P,_R} = inop_prec('#'), Rl = lexpr(Map, L, Opts), - El = {first,[Rl,leaf("#")],map_fields(Fs, Opts)}, + El = {first,[Rl,$#],map_fields(Fs, Opts)}, maybe_paren(P, Prec, El); lexpr({block,_,Es}, _, Opts) -> {list,[{step,'begin',body(Es, Opts)},'end']}; @@ -557,13 +572,16 @@ lexpr({'receive',_,Cs,To,ToOpt}, _, Opts) -> {step,'after',Al}, 'end']}; lexpr({'fun',_,{function,F,A}}, _Prec, _Opts) -> - leaf(format("fun ~w/~w", [F,A])); -lexpr({'fun',_,{function,F,A},Extra}, _Prec, _Opts) -> - {force_nl,fun_info(Extra),leaf(format("fun ~w/~w", [F,A]))}; -lexpr({'fun',_,{function,M,F,A}}, _Prec, _Opts) + [leaf("fun "),{atom,F},leaf(format("/~w", [A]))]; +lexpr({'fun',L,{function,_,_}=Func,Extra}, Prec, Opts) -> + {force_nl,fun_info(Extra),lexpr({'fun',L,Func}, Prec, Opts)}; +lexpr({'fun',L,{function,M,F,A}}, Prec, Opts) when is_atom(M), is_atom(F), is_integer(A) -> %% For backward compatibility with pre-R15 abstract format. - leaf(format("fun ~w:~w/~w", [M,F,A])); + Mod = erl_parse:abstract(M), + Fun = erl_parse:abstract(F), + Arity = erl_parse:abstract(A), + lexpr({'fun',L,{function,Mod,Fun,Arity}}, Prec, Opts); lexpr({'fun',_,{function,M,F,A}}, _Prec, Opts) -> %% New format in R15. NameItem = lexpr(M, Opts), @@ -654,7 +672,7 @@ lexpr({bin,_,Fs}, _, Opts) -> bit_grp(Fs, Opts); %% Special case for straight values. lexpr({value,_,Val}, _,_) -> - leaf(write(Val)); + {value,Val}; %% Now do the hook. lexpr(Other, _Precedence, #options{hook = none}) -> leaf(format("INVALID-FORM:~w:",[Other])); @@ -670,7 +688,7 @@ call(Name, Args, Prec, Opts) -> maybe_paren(P, Prec, Item). fun_info(Extra) -> - leaf(format("% fun-info: ~w", [Extra])). + [leaf("% fun-info: "),{value,Extra}]. %% BITS: @@ -711,7 +729,7 @@ bit_elem_type(T) -> %% end of BITS record_name(Name) -> - leaf(format("#~w", [Name])). + [$#,{atom,Name}]. record_fields(Fs, Opts) -> tuple(Fs, fun record_field/2, Opts). @@ -913,8 +931,10 @@ frmt(Item, I, PP) -> %%% - {force_nl,ExtraInfo,I}: fun-info (a comment) forces linebreak before I. %%% - {prefer_nl,Sep,IPs}: forces linebreak between Is unlesss negative %%% indentation. +%%% - {atom,A}: an atom %%% - {char,C}: a character %%% - {string,S}: a string. +%%% - {value,T}: a term. %%% - {hook,...}, {ehook,...}: hook expressions. %%% %%% list, first, seq, force_nl, and prefer_nl all accept IPs, where each @@ -975,6 +995,10 @@ f({prefer_nl,Sep,LItems}, I0, ST, WT, PP) -> true -> {insert_newlines(CharsSize2L, I0, ST),nsz(lists:last(Sizes), I0)} end; +f({value,V}, I, ST, WT, PP) -> + f(write_a_value(V, PP), I, ST, WT, PP); +f({atom,A}, I, ST, WT, PP) -> + f(write_an_atom(A, PP), I, ST, WT, PP); f({char,C}, I, ST, WT, PP) -> f(write_a_char(C, PP), I, ST, WT, PP); f({string,S}, I, ST, WT, PP) -> @@ -1113,6 +1137,12 @@ has_nl([C|Cs]) -> has_nl([]) -> false. +write_a_value(V, PP) -> + flat_leaf(write_value(V, PP)). + +write_an_atom(A, PP) -> + flat_leaf(write_atom(A, PP)). + write_a_char(C, PP) -> flat_leaf(write_char(C, PP)). @@ -1129,7 +1159,7 @@ write_a_string([], _N, _Len, _PP) -> write_a_string(S, N, Len, PP) -> SS = string:sub_string(S, 1, N), Sl = write_string(SS, PP), - case (length(Sl) > Len) and (N > ?MIN_SUBSTRING) of + case (chars_size(Sl) > Len) and (N > ?MIN_SUBSTRING) of true -> write_a_string(S, N-1, Len, PP); false -> @@ -1141,11 +1171,17 @@ flat_leaf(S) -> L = lists:flatten(S), {leaf,length(L),L}. +write_value(V, PP) -> + (PP#pp.value_fun)(V). + +write_atom(A, PP) -> + (PP#pp.value_fun)(A). + write_string(S, PP) -> - lists:flatten((PP#pp.string_fun)(S)). + (PP#pp.string_fun)(S). write_char(C, PP) -> - lists:flatten((PP#pp.char_fun)(C)). + (PP#pp.char_fun)(C). %% %% Utilities diff --git a/lib/stdlib/src/erl_scan.erl b/lib/stdlib/src/erl_scan.erl index d2f53816b8..47223b129c 100644 --- a/lib/stdlib/src/erl_scan.erl +++ b/lib/stdlib/src/erl_scan.erl @@ -52,25 +52,15 @@ %%% External exports -export([string/1,string/2,string/3,tokens/3,tokens/4, - format_error/1,reserved_word/1, - token_info/1,token_info/2, - attributes_info/1,attributes_info/2,set_attribute/3]). + format_error/1,reserved_word/1]). -export([column/1,end_location/1,line/1,location/1,text/1, category/1,symbol/1]). --deprecated([{attributes_info, 1, next_major_release}, - {attributes_info, 2, next_major_release}, - {set_attribute, 3, next_major_release}, - {token_info, 1, next_major_release}, - {token_info, 2, next_major_release}]). - %%% Private -export([continuation_location/1]). -export_type([error_info/0, - line/0, - location/0, options/0, return_cont/0, token/0, @@ -85,29 +75,18 @@ -define(ALINE(L), is_integer(L)). -define(STRING(S), is_list(S)). -define(RESWORDFUN(F), is_function(F, 1)). --define(SETATTRFUN(F), is_function(F, 1)). -type category() :: atom(). --type column() :: pos_integer(). % Deprecated --type line() :: integer(). % Deprecated --type location() :: line() | {line(),column()}. % Deprecated -type resword_fun() :: fun((atom()) -> boolean()). -type option() :: 'return' | 'return_white_spaces' | 'return_comments' | 'text' | {'reserved_word_fun', resword_fun()}. -type options() :: option() | [option()]. -type symbol() :: atom() | float() | integer() | string(). --type info_line() :: integer() | term(). --type attributes_data() - :: [{'column', column()} | {'line', info_line()} | {'text', string()}] - | {line(), column()}. -%% The fact that {line(),column()} is a possible attributes() type -%% is hidden. --type attributes() :: line() | attributes_data(). --type token() :: {category(), attributes(), symbol()} - | {category(), attributes()}. +-type token() :: {category(), Anno :: erl_anno:anno(), symbol()} + | {category(), Anno :: erl_anno:anno()}. -type tokens() :: [token()]. -type error_description() :: term(). --type error_info() :: {location(), module(), error_description()}. +-type error_info() :: {erl_anno:location(), module(), error_description()}. %%% Local record. -record(erl_scan, @@ -136,8 +115,8 @@ format_error(Other) -> String :: string(), Return :: {'ok', Tokens :: tokens(), EndLocation} | {'error', ErrorInfo :: error_info(), ErrorLocation}, - EndLocation :: location(), - ErrorLocation :: location(). + EndLocation :: erl_anno:location(), + ErrorLocation :: erl_anno:location(). string(String) -> string(String, 1, []). @@ -145,9 +124,9 @@ string(String) -> String :: string(), Return :: {'ok', Tokens :: tokens(), EndLocation} | {'error', ErrorInfo :: error_info(), ErrorLocation}, - StartLocation :: location(), - EndLocation :: location(), - ErrorLocation :: location(). + StartLocation :: erl_anno:location(), + EndLocation :: erl_anno:location(), + ErrorLocation :: erl_anno:location(). string(String, StartLocation) -> string(String, StartLocation, []). @@ -156,9 +135,9 @@ string(String, StartLocation) -> Options :: options(), Return :: {'ok', Tokens :: tokens(), EndLocation} | {'error', ErrorInfo :: error_info(), ErrorLocation}, - StartLocation :: location(), - EndLocation :: location(), - ErrorLocation :: location(). + StartLocation :: erl_anno:location(), + EndLocation :: erl_anno:location(), + ErrorLocation :: erl_anno:location(). string(String, Line, Options) when ?STRING(String), ?ALINE(Line) -> string1(String, options(Options), Line, no_col, []); string(String, {Line,Column}, Options) when ?STRING(String), @@ -167,20 +146,23 @@ string(String, {Line,Column}, Options) when ?STRING(String), string1(String, options(Options), Line, Column, []). -type char_spec() :: string() | 'eof'. --type cont_fun() :: fun((char_spec(), #erl_scan{}, line(), column(), +-type cont_fun() :: fun((char_spec(), #erl_scan{}, + erl_anno:line(), erl_anno:column(), tokens(), any()) -> any()). -opaque return_cont() :: {erl_scan_continuation, - string(), column(), tokens(), line(), + string(), erl_anno:column(), tokens(), + erl_anno:line(), #erl_scan{}, any(), cont_fun()}. --type tokens_result() :: {'ok', Tokens :: tokens(), EndLocation :: location()} - | {'eof', EndLocation :: location()} +-type tokens_result() :: {'ok', Tokens :: tokens(), + EndLocation :: erl_anno:location()} + | {'eof', EndLocation :: erl_anno:location()} | {'error', ErrorInfo :: error_info(), - EndLocation :: location()}. + EndLocation :: erl_anno:location()}. -spec tokens(Continuation, CharSpec, StartLocation) -> Return when Continuation :: return_cont() | [], CharSpec :: char_spec(), - StartLocation :: location(), + StartLocation :: erl_anno:location(), Return :: {'done',Result :: tokens_result(),LeftOverChars :: char_spec()} | {'more', Continuation1 :: return_cont()}. tokens(Cont, CharSpec, StartLocation) -> @@ -189,7 +171,7 @@ tokens(Cont, CharSpec, StartLocation) -> -spec tokens(Continuation, CharSpec, StartLocation, Options) -> Return when Continuation :: return_cont() | [], CharSpec :: char_spec(), - StartLocation :: location(), + StartLocation :: erl_anno:location(), Options :: options(), Return :: {'done',Result :: tokens_result(),LeftOverChars :: char_spec()} | {'more', Continuation1 :: return_cont()}. @@ -257,155 +239,6 @@ symbol({_Category,_Anno,Symbol}) -> symbol(T) -> erlang:error(badarg, [T]). --type attribute_item() :: 'column' | 'length' | 'line' - | 'location' | 'text'. --type info_location() :: location() | term(). --type attribute_info() :: {'column', column()}| {'length', pos_integer()} - | {'line', info_line()} - | {'location', info_location()} - | {'text', string()}. --type token_item() :: 'category' | 'symbol' | attribute_item(). --type token_info() :: {'category', category()} | {'symbol', symbol()} - | attribute_info(). - --spec token_info(Token) -> TokenInfo when - Token :: token(), - TokenInfo :: [TokenInfoTuple :: token_info()]. -token_info(Token) -> - Items = [category,column,length,line,symbol,text], % undefined order - token_info(Token, Items). - --spec token_info(Token, TokenItem) -> TokenInfoTuple | 'undefined' when - Token :: token(), - TokenItem :: token_item(), - TokenInfoTuple :: token_info(); - (Token, TokenItems) -> TokenInfo when - Token :: token(), - TokenItems :: [TokenItem :: token_item()], - TokenInfo :: [TokenInfoTuple :: token_info()]. -token_info(_Token, []) -> - []; -token_info(Token, [Item|Items]) when is_atom(Item) -> - case token_info(Token, Item) of - undefined -> - token_info(Token, Items); - TokenInfo when is_tuple(TokenInfo) -> - [TokenInfo|token_info(Token, Items)] - end; -token_info({Category,_Attrs}, category=Item) -> - {Item,Category}; -token_info({Category,_Attrs,_Symbol}, category=Item) -> - {Item,Category}; -token_info({Category,_Attrs}, symbol=Item) -> - {Item,Category}; -token_info({_Category,_Attrs,Symbol}, symbol=Item) -> - {Item,Symbol}; -token_info({_Category,Attrs}, Item) -> - attributes_info(Attrs, Item); -token_info({_Category,Attrs,_Symbol}, Item) -> - attributes_info(Attrs, Item). - --spec attributes_info(Attributes) -> AttributesInfo when - Attributes :: attributes(), - AttributesInfo :: [AttributeInfoTuple :: attribute_info()]. -attributes_info(Attributes) -> - Items = [column,length,line,text], % undefined order - attributes_info(Attributes, Items). - --spec attributes_info - (Attributes, AttributeItem) -> AttributeInfoTuple | 'undefined' when - Attributes :: attributes(), - AttributeItem :: attribute_item(), - AttributeInfoTuple :: attribute_info(); - (Attributes, AttributeItems) -> AttributeInfo when - Attributes :: attributes(), - AttributeItems :: [AttributeItem :: attribute_item()], - AttributeInfo :: [AttributeInfoTuple :: attribute_info()]. -attributes_info(_Attrs, []) -> - []; -attributes_info(Attrs, [A|As]) when is_atom(A) -> - case attributes_info(Attrs, A) of - undefined -> - attributes_info(Attrs, As); - AttributeInfo when is_tuple(AttributeInfo) -> - [AttributeInfo|attributes_info(Attrs, As)] - end; -attributes_info({Line,Column}, column=Item) when ?ALINE(Line), - ?COLUMN(Column) -> - {Item,Column}; -attributes_info(Line, column) when ?ALINE(Line) -> - undefined; -attributes_info(Attrs, column=Item) -> - case attr_info(Attrs, Item) of - undefined -> - case erl_anno:column(Attrs) of - undefined -> - undefined; - Column -> - {Item,Column} - end; - T -> - T - end; -attributes_info(Attrs, length=Item) -> - case attributes_info(Attrs, text) of - undefined -> - undefined; - {text,Text} -> - {Item,length(Text)} - end; -attributes_info(Line, line=Item) when ?ALINE(Line) -> - {Item,Line}; -attributes_info({Line,Column}, line=Item) when ?ALINE(Line), - ?COLUMN(Column) -> - {Item,Line}; -attributes_info(Attrs, line=Item) -> - case attr_info(Attrs, Item) of - undefined -> - case attr_info(Attrs, location) of - {location,{Line,_Column}} -> - {Item,Line}; - {location,Line} -> - {Item,Line}; - undefined -> - undefined - end; - T -> - T - end; -attributes_info({Line,Column}=Location, location=Item) when ?ALINE(Line), - ?COLUMN(Column) -> - {Item,Location}; -attributes_info(Line, location=Item) when ?ALINE(Line) -> - {Item,Line}; -attributes_info(Attrs, location=Item) -> - {line,Line} = attributes_info(Attrs, line), - case attributes_info(Attrs, column) of - undefined -> - %% If set_attribute() has assigned a term such as {17,42} - %% to 'line', then Line will look like {Line,Column}. One - %% should not use 'location' but 'line' and 'column' in - %% such special cases. - {Item,Line}; - {column,Column} -> - {Item,{Line,Column}} - end; -attributes_info({Line,Column}, text) when ?ALINE(Line), ?COLUMN(Column) -> - undefined; -attributes_info(Line, text) when ?ALINE(Line) -> - undefined; -attributes_info(Attrs, text=Item) -> - attr_info(Attrs, Item); -attributes_info(T1, T2) -> - erlang:error(badarg, [T1,T2]). - --spec set_attribute(AttributeItem, Attributes, SetAttributeFun) -> Attributes when - AttributeItem :: 'line', - Attributes :: attributes(), - SetAttributeFun :: fun((info_line()) -> info_line()). -set_attribute(Tag, Attributes, Fun) when ?SETATTRFUN(Fun) -> - set_attr(Tag, Attributes, Fun). - %%% %%% Local functions %%% @@ -471,62 +304,6 @@ expand_opt(return, Os) -> expand_opt(O, Os) -> [O|Os]. -attr_info(Attrs, Item) -> - try lists:keyfind(Item, 1, Attrs) of - {_Item, _Value} = T -> - T; - false -> - undefined - catch - _:_ -> - erlang:error(badarg, [Attrs, Item]) - end. - --spec set_attr('line', attributes(), fun((line()) -> line())) -> attributes(). - -set_attr(line, Line, Fun) when ?ALINE(Line) -> - Ln = Fun(Line), - if - ?ALINE(Ln) -> - Ln; - true -> - [{line,Ln}] - end; -set_attr(line, {Line,Column}, Fun) when ?ALINE(Line), ?COLUMN(Column) -> - Ln = Fun(Line), - if - ?ALINE(Ln) -> - {Ln,Column}; - true -> - [{line,Ln},{column,Column}] - end; -set_attr(line=Tag, Attrs, Fun) when is_list(Attrs) -> - case lists:keyfind(Tag, 1, Attrs) of - {line,Line} -> - case lists:keyreplace(Tag, 1, Attrs, {line,Fun(Line)}) of - [{line,Ln}] when ?ALINE(Ln) -> - Ln; - As -> - As - end; - false -> - {location, Location} = lists:keyfind(location, 1, Attrs), - Ln = case Location of - {Line,Column} when ?ALINE(Line), ?COLUMN(Column) -> - {Fun(Line),Column}; - _ -> - Fun(Location) - end, - case lists:keyreplace(location, 1, Attrs, {location,Ln}) of - [{location,Ln}] when ?ALINE(Ln) -> - Ln; - As -> - As - end - end; -set_attr(T1, T2, T3) -> - erlang:error(badarg, [T1,T2,T3]). - tokens1(Cs, St, Line, Col, Toks, Fun, Any) when ?STRING(Cs); Cs =:= eof -> case Fun(Cs, St, Line, Col, Toks, Any) of {more,{Cs0,Ncol,Ntoks,Nline,Nany,Nfun}} -> diff --git a/lib/stdlib/src/erl_tar.erl b/lib/stdlib/src/erl_tar.erl index d0e7a827a8..5ee584d612 100644 --- a/lib/stdlib/src/erl_tar.erl +++ b/lib/stdlib/src/erl_tar.erl @@ -1,8 +1,8 @@ %% %% %CopyrightBegin% -%% -%% Copyright Ericsson AB 1997-2013. All Rights Reserved. -%% +%% +%% Copyright Ericsson AB 1997-2017. All Rights Reserved. +%% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. %% You may obtain a copy of the License at @@ -14,191 +14,259 @@ %% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. %% See the License for the specific language governing permissions and %% limitations under the License. -%% +%% %% %CopyrightEnd% %% +%% This module implements extraction/creation of tar archives. +%% It supports reading most common tar formats, namely V7, STAR, +%% USTAR, GNU, BSD/libarchive, and PAX. It produces archives in USTAR +%% format, unless it must use PAX headers, in which case it produces PAX +%% format. +%% +%% The following references where used: +%% http://www.freebsd.org/cgi/man.cgi?query=tar&sektion=5 +%% http://www.gnu.org/software/tar/manual/html_node/Standard.html +%% http://pubs.opengroup.org/onlinepubs/9699919799/utilities/pax.html -module(erl_tar). -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Purpose: Unix tar (tape archive) utility. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - --export([init/3, create/2, create/3, extract/1, extract/2, table/1, table/2, - open/2, close/1, add/3, add/4, - t/1, tt/1, format_error/1]). +-export([init/3, + create/2, create/3, + extract/1, extract/2, + table/1, table/2, t/1, tt/1, + open/2, close/1, + add/3, add/4, + format_error/1]). -include_lib("kernel/include/file.hrl"). +-include_lib("erl_tar.hrl"). --record(add_opts, - {read_info, % Fun to use for read file/link info. - chunk_size = 0, % For file reading when sending to sftp. 0=do not chunk - verbose = false :: boolean()}). % Verbose on/off. - -%% Opens a tar archive. - -init(UsrHandle, AccessMode, Fun) when is_function(Fun,2) -> - {ok, {AccessMode,{tar_descriptor,UsrHandle,Fun}}}. - -%%%================================================================ -%%% The open function with friends is to keep the file and binary api of this module -open(Name, Mode) -> - case open_mode(Mode) of - {ok, Access, Raw, Opts} -> - open1(Name, Access, Raw, Opts); - {error, Reason} -> - {error, {Name, Reason}} - end. - -open1({binary,Bin}, read, _Raw, Opts) -> - case file:open(Bin, [ram,binary,read]) of - {ok,File} -> - _ = [ram_file:uncompress(File) || Opts =:= [compressed]], - init(File,read,file_fun()); - Error -> - Error - end; -open1({file, Fd}, read, _Raw, _Opts) -> - init(Fd, read, file_fun()); -open1(Name, Access, Raw, Opts) -> - case file:open(Name, Raw ++ [binary, Access|Opts]) of - {ok, File} -> - init(File, Access, file_fun()); - {error, Reason} -> - {error, {Name, Reason}} - end. - -file_fun() -> - fun(write, {Fd,Data}) -> file:write(Fd, Data); - (position, {Fd,Pos}) -> file:position(Fd, Pos); - (read2, {Fd,Size}) -> file:read(Fd,Size); - (close, Fd) -> file:close(Fd) - end. - -%%% End of file and binary api (except for open_mode/1 downwards -%%%================================================================ - -%% Closes a tar archive. - -close({read, File}) -> - ok = do_close(File); -close({write, File}) -> - PadResult = pad_file(File), - ok = do_close(File), - PadResult; -close(_) -> - {error, einval}. - -%% Adds a file to a tape archive. - -add(File, Name, Options) -> - add(File, Name, Name, Options). -add({write, File}, Name, NameInArchive, Options) -> - Opts = #add_opts{read_info=fun(F) -> file:read_link_info(F) end}, - add1(File, Name, NameInArchive, add_opts(Options, Opts)); -add({read, _File}, _, _, _) -> - {error, eacces}; -add(_, _, _, _) -> - {error, einval}. - -add_opts([dereference|T], Opts) -> - add_opts(T, Opts#add_opts{read_info=fun(F) -> file:read_file_info(F) end}); -add_opts([verbose|T], Opts) -> - add_opts(T, Opts#add_opts{verbose=true}); -add_opts([{chunks,N}|T], Opts) -> - add_opts(T, Opts#add_opts{chunk_size=N}); -add_opts([_|T], Opts) -> - add_opts(T, Opts); -add_opts([], Opts) -> - Opts. - -%% Creates a tar file Name containing the given files. - -create(Name, Filenames) -> - create(Name, Filenames, []). - -%% Creates a tar archive Name containing the given files. -%% Accepted options: verbose, compressed, cooked +%% Converts the short error reason to a descriptive string. +-spec format_error(term()) -> string(). +format_error(invalid_tar_checksum) -> + "Checksum failed"; +format_error(bad_header) -> + "Unrecognized tar header format"; +format_error({bad_header, Reason}) -> + lists:flatten(io_lib:format("Unrecognized tar header format: ~p", [Reason])); +format_error({invalid_header, negative_size}) -> + "Invalid header: negative size"; +format_error(invalid_sparse_header_size) -> + "Invalid sparse header: negative size"; +format_error(invalid_sparse_map_entry) -> + "Invalid sparse map entry"; +format_error({invalid_sparse_map_entry, Reason}) -> + lists:flatten(io_lib:format("Invalid sparse map entry: ~p", [Reason])); +format_error(invalid_end_of_archive) -> + "Invalid end of archive"; +format_error(eof) -> + "Unexpected end of file"; +format_error(integer_overflow) -> + "Failed to parse numeric: integer overflow"; +format_error({misaligned_read, Pos}) -> + lists:flatten(io_lib:format("Read a block which was misaligned: block_size=~p pos=~p", + [?BLOCK_SIZE, Pos])); +format_error(invalid_gnu_1_0_sparsemap) -> + "Invalid GNU sparse map (version 1.0)"; +format_error({invalid_gnu_0_1_sparsemap, Format}) -> + lists:flatten(io_lib:format("Invalid GNU sparse map (version ~s)", [Format])); +format_error(unsafe_path) -> + "The path points above the current working directory"; +format_error({Name,Reason}) -> + lists:flatten(io_lib:format("~ts: ~ts", [Name,format_error(Reason)])); +format_error(Atom) when is_atom(Atom) -> + file:format_error(Atom); +format_error(Term) -> + lists:flatten(io_lib:format("~tp", [Term])). -create(Name, FileList, Options) -> - Mode = lists:filter(fun(X) -> (X=:=compressed) or (X=:=cooked) - end, Options), - case open(Name, [write|Mode]) of - {ok, TarFile} -> - Add = fun({NmInA, NmOrBin}) -> - add(TarFile, NmOrBin, NmInA, Options); - (Nm) -> - add(TarFile, Nm, Nm, Options) - end, - Result = foreach_while_ok(Add, FileList), - case {Result, close(TarFile)} of - {ok, Res} -> Res; - {Res, _} -> Res - end; - Reason -> - Reason - end. +%% Initializes a new reader given a custom file handle and I/O wrappers +-spec init(handle(), write | read, file_op()) -> {ok, reader()} | {error, badarg}. +init(Handle, AccessMode, Fun) when is_function(Fun, 2) -> + Reader = #reader{handle=Handle,access=AccessMode,func=Fun}, + {ok, Pos, Reader2} = do_position(Reader, {cur, 0}), + {ok, Reader2#reader{pos=Pos}}; +init(_Handle, _AccessMode, _Fun) -> + {error, badarg}. +%%%================================================================ %% Extracts all files from the tar file Name. - +-spec extract(open_handle()) -> ok | {error, term()}. extract(Name) -> extract(Name, []). %% Extracts (all) files from the tar file Name. -%% Options accepted: keep_old_files, {files, ListOfFilesToExtract}, verbose, -%% {cwd, AbsoluteDirectory} +%% Options accepted: +%% - cooked: Opens the tar file without mode `raw` +%% - compressed: Uncompresses the tar file when reading +%% - memory: Returns the tar contents as a list of tuples {Name, Bin} +%% - keep_old_files: Extracted files will not overwrite the destination +%% - {files, ListOfFilesToExtract}: Only extract ListOfFilesToExtract +%% - verbose: Prints verbose information about the extraction, +%% - {cwd, AbsoluteDir}: Sets the current working directory for the extraction +-spec extract(open_handle(), [extract_opt()]) -> + ok + | {ok, [{string(), binary()}]} + | {error, term()}. +extract({binary, Bin}, Opts) when is_list(Opts) -> + do_extract({binary, Bin}, Opts); +extract({file, Fd}, Opts) when is_list(Opts) -> + do_extract({file, Fd}, Opts); +extract(#reader{}=Reader, Opts) when is_list(Opts) -> + do_extract(Reader, Opts); +extract(Name, Opts) when is_list(Name); is_binary(Name), is_list(Opts) -> + do_extract(Name, Opts). + +do_extract(Handle, Opts) when is_list(Opts) -> + Opts2 = extract_opts(Opts), + Acc = if Opts2#read_opts.output =:= memory -> []; true -> ok end, + foldl_read(Handle, fun extract1/4, Acc, Opts2). + +extract1(eof, Reader, _, Acc) when is_list(Acc) -> + {ok, {ok, lists:reverse(Acc)}, Reader}; +extract1(eof, Reader, _, leading_slash) -> + error_logger:info_msg("erl_tar: removed leading '/' from member names\n"), + {ok, ok, Reader}; +extract1(eof, Reader, _, Acc) -> + {ok, Acc, Reader}; +extract1(#tar_header{name=Name,size=Size}=Header, Reader0, Opts, Acc0) -> + case check_extract(Name, Opts) of + true -> + case do_read(Reader0, Size) of + {ok, Bin, Reader1} -> + Acc = extract2(Header, Bin, Opts, Acc0), + {ok, Acc, Reader1}; + {error, _} = Err -> + throw(Err) + end; + false -> + {ok, Acc0, skip_file(Reader0)} + end. -extract(Name, Opts) -> - foldl_read(Name, fun extract1/4, ok, extract_opts(Opts)). +extract2(Header, Bin, Opts, Acc) -> + case write_extracted_element(Header, Bin, Opts) of + ok -> + case Header of + #tar_header{name="/"++_} -> + leading_slash; + #tar_header{} -> + Acc + end; + {ok, NameBin} when is_list(Acc) -> + [NameBin | Acc]; + {error, _} = Err -> + throw(Err) + end. -%% Returns a list of names of the files in the tar file Name. -%% Options accepted: verbose +%% Checks if the file Name should be extracted. +check_extract(_, #read_opts{files=all}) -> + true; +check_extract(Name, #read_opts{files=Files}) -> + ordsets:is_element(Name, Files). + +%%%================================================================ +%% The following table functions produce a list of information about +%% the files contained in the archive. +-type filename() :: string(). +-type typeflag() :: regular | link | symlink | + char | block | directory | + fifo | reserved | unknown. +-type mode() :: non_neg_integer(). +-type uid() :: non_neg_integer(). +-type gid() :: non_neg_integer(). + +-type tar_entry() :: {filename(), + typeflag(), + non_neg_integer(), + tar_time(), + mode(), + uid(), + gid()}. +%% Returns a list of names of the files in the tar file Name. +-spec table(open_handle()) -> {ok, [string()]} | {error, term()}. table(Name) -> table(Name, []). %% Returns a list of names of the files in the tar file Name. %% Options accepted: compressed, verbose, cooked. - -table(Name, Opts) -> +-spec table(open_handle(), [compressed | verbose | cooked]) -> + {ok, [string() | tar_entry()]} | {error, term()}. +table(Name, Opts) when is_list(Opts) -> foldl_read(Name, fun table1/4, [], table_opts(Opts)). +table1(eof, Reader, _, Result) -> + {ok, {ok, lists:reverse(Result)}, Reader}; +table1(#tar_header{}=Header, Reader, #read_opts{verbose=Verbose}, Result) -> + Attrs = table1_attrs(Header, Verbose), + Reader2 = skip_file(Reader), + {ok, [Attrs|Result], Reader2}. +%% Extracts attributes relevant to table1's output +table1_attrs(#tar_header{typeflag=Typeflag,mode=Mode}=Header, true) -> + Type = typeflag(Typeflag), + Name = Header#tar_header.name, + Mtime = Header#tar_header.mtime, + Uid = Header#tar_header.uid, + Gid = Header#tar_header.gid, + Size = Header#tar_header.size, + {Name, Type, Size, Mtime, Mode, Uid, Gid}; +table1_attrs(#tar_header{name=Name}, _Verbose) -> + Name. + +typeflag(?TYPE_REGULAR) -> regular; +typeflag(?TYPE_REGULAR_A) -> regular; +typeflag(?TYPE_GNU_SPARSE) -> regular; +typeflag(?TYPE_CONT) -> regular; +typeflag(?TYPE_LINK) -> link; +typeflag(?TYPE_SYMLINK) -> symlink; +typeflag(?TYPE_CHAR) -> char; +typeflag(?TYPE_BLOCK) -> block; +typeflag(?TYPE_DIR) -> directory; +typeflag(?TYPE_FIFO) -> fifo; +typeflag(_) -> unknown. + +%%%================================================================ %% Comments for printing the contents of a tape archive, %% meant to be invoked from the shell. -t(Name) -> +%% Prints each filename in the archive +-spec t(file:filename()) -> ok | {error, term()}. +t(Name) when is_list(Name); is_binary(Name) -> case table(Name) of - {ok, List} -> - lists:foreach(fun(N) -> ok = io:format("~ts\n", [N]) end, List); - Error -> - Error + {ok, List} -> + lists:foreach(fun(N) -> ok = io:format("~ts\n", [N]) end, List); + Error -> + Error end. +%% Prints verbose information about each file in the archive +-spec tt(open_handle()) -> ok | {error, term()}. tt(Name) -> case table(Name, [verbose]) of - {ok, List} -> - lists:foreach(fun print_header/1, List); - Error -> - Error + {ok, List} -> + lists:foreach(fun print_header/1, List); + Error -> + Error end. +%% Used by tt/1 to print a tar_entry tuple +-spec print_header(tar_entry()) -> ok. print_header({Name, Type, Size, Mtime, Mode, Uid, Gid}) -> io:format("~s~s ~4w/~-4w ~7w ~s ~s\n", - [type_to_string(Type), mode_to_string(Mode), - Uid, Gid, Size, time_to_string(Mtime), Name]). + [type_to_string(Type), mode_to_string(Mode), + Uid, Gid, Size, time_to_string(Mtime), Name]). -type_to_string(regular) -> "-"; +type_to_string(regular) -> "-"; type_to_string(directory) -> "d"; -type_to_string(link) -> "l"; -type_to_string(symlink) -> "s"; -type_to_string(char) -> "c"; -type_to_string(block) -> "b"; -type_to_string(fifo) -> "f"; -type_to_string(_) -> "?". - +type_to_string(link) -> "l"; +type_to_string(symlink) -> "s"; +type_to_string(char) -> "c"; +type_to_string(block) -> "b"; +type_to_string(fifo) -> "f"; +type_to_string(unknown) -> "?". + +%% Converts a numeric mode to its human-readable representation mode_to_string(Mode) -> mode_to_string(Mode, "xwrxwrxwr", []). - mode_to_string(Mode, [C|T], Acc) when Mode band 1 =:= 1 -> mode_to_string(Mode bsr 1, T, [C|Acc]); mode_to_string(Mode, [_|T], Acc) -> @@ -206,7 +274,13 @@ mode_to_string(Mode, [_|T], Acc) -> mode_to_string(_, [], Acc) -> Acc. -time_to_string({{Y, Mon, Day}, {H, Min, _}}) -> +%% Converts a tar_time() (POSIX time) to a readable string +time_to_string(Secs0) -> + Epoch = calendar:datetime_to_gregorian_seconds(?EPOCH), + Secs = Epoch + Secs0, + DateTime0 = calendar:gregorian_seconds_to_datetime(Secs), + DateTime = calendar:universal_time_to_local_time(DateTime0), + {{Y, Mon, Day}, {H, Min, _}} = DateTime, io_lib:format("~s ~2w ~s:~s ~w", [month(Mon), Day, two_d(H), two_d(Min), Y]). two_d(N) -> @@ -225,809 +299,1607 @@ month(10) -> "Oct"; month(11) -> "Nov"; month(12) -> "Dec". -%% Converts the short error reason to a descriptive string. +%%%================================================================ +%% The open function with friends is to keep the file and binary api of this module +-type open_handle() :: file:filename() + | {binary, binary()} + | {file, term()}. +-spec open(open_handle(), [write | compressed | cooked]) -> + {ok, reader()} | {error, term()}. +open({binary, Bin}, Mode) when is_binary(Bin) -> + do_open({binary, Bin}, Mode); +open({file, Fd}, Mode) -> + do_open({file, Fd}, Mode); +open(Name, Mode) when is_list(Name); is_binary(Name) -> + do_open(Name, Mode). + +do_open(Name, Mode) when is_list(Mode) -> + case open_mode(Mode) of + {ok, Access, Raw, Opts} -> + open1(Name, Access, Raw, Opts); + {error, Reason} -> + {error, {Name, Reason}} + end. -format_error(bad_header) -> "Bad directory header"; -format_error(eof) -> "Unexpected end of file"; -format_error(symbolic_link_too_long) -> "Symbolic link too long"; -format_error({Name,Reason}) -> - lists:flatten(io_lib:format("~ts: ~ts", [Name,format_error(Reason)])); -format_error(Atom) when is_atom(Atom) -> - file:format_error(Atom); -format_error(Term) -> - lists:flatten(io_lib:format("~tp", [Term])). +open1({binary,Bin}, read, _Raw, Opts) when is_binary(Bin) -> + case file:open(Bin, [ram,binary,read]) of + {ok,File} -> + _ = [ram_file:uncompress(File) || Opts =:= [compressed]], + {ok, #reader{handle=File,access=read,func=fun file_op/2}}; + Error -> + Error + end; +open1({file, Fd}, read, _Raw, _Opts) -> + Reader = #reader{handle=Fd,access=read,func=fun file_op/2}, + case do_position(Reader, {cur, 0}) of + {ok, Pos, Reader2} -> + {ok, Reader2#reader{pos=Pos}}; + {error, _} = Err -> + Err + end; +open1(Name, Access, Raw, Opts) when is_list(Name) or is_binary(Name) -> + case file:open(Name, Raw ++ [binary, Access|Opts]) of + {ok, File} -> + {ok, #reader{handle=File,access=Access,func=fun file_op/2}}; + {error, Reason} -> + {error, {Name, Reason}} + end. +open_mode(Mode) -> + open_mode(Mode, false, [raw], []). + +open_mode(read, _, Raw, _) -> + {ok, read, Raw, []}; +open_mode(write, _, Raw, _) -> + {ok, write, Raw, []}; +open_mode([read|Rest], false, Raw, Opts) -> + open_mode(Rest, read, Raw, Opts); +open_mode([write|Rest], false, Raw, Opts) -> + open_mode(Rest, write, Raw, Opts); +open_mode([compressed|Rest], Access, Raw, Opts) -> + open_mode(Rest, Access, Raw, [compressed|Opts]); +open_mode([cooked|Rest], Access, _Raw, Opts) -> + open_mode(Rest, Access, [], Opts); +open_mode([], Access, Raw, Opts) -> + {ok, Access, Raw, Opts}; +open_mode(_, _, _, _) -> + {error, einval}. + +file_op(write, {Fd, Data}) -> + file:write(Fd, Data); +file_op(position, {Fd, Pos}) -> + file:position(Fd, Pos); +file_op(read2, {Fd, Size}) -> + file:read(Fd, Size); +file_op(close, Fd) -> + file:close(Fd). + +%% Closes a tar archive. +-spec close(reader()) -> ok | {error, term()}. +close(#reader{access=read}=Reader) -> + ok = do_close(Reader); +close(#reader{access=write}=Reader) -> + {ok, Reader2} = pad_file(Reader), + ok = do_close(Reader2), + ok; +close(_) -> + {error, einval}. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%% -%%% Useful definitions (also start of implementation). -%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -%% Offset for fields in the tar header. -%% Note that these offsets are ZERO-based as in the POSIX standard -%% document, while binaries use ONE-base offset. Caveat Programmer. - --define(th_name, 0). --define(th_mode, 100). --define(th_uid, 108). --define(th_gid, 116). --define(th_size, 124). --define(th_mtime, 136). --define(th_chksum, 148). --define(th_typeflag, 156). --define(th_linkname, 157). --define(th_magic, 257). --define(th_version, 263). --define(th_prefix, 345). - -%% Length of these fields. - --define(th_name_len, 100). --define(th_mode_len, 8). --define(th_uid_len, 8). --define(th_gid_len, 8). --define(th_size_len, 12). --define(th_mtime_len, 12). --define(th_chksum_len, 8). --define(th_linkname_len, 100). --define(th_magic_len, 6). --define(th_version_len, 2). --define(th_prefix_len, 167). - --record(tar_header, - {name, % Name of file. - mode, % Mode bits. - uid, % User id. - gid, % Group id. - size, % Size of file - mtime, % Last modified (seconds since - % Jan 1, 1970). - chksum, % Checksum of header. - typeflag = [], % Type of file. - linkname = [], % Name of link. - filler = [], - prefix}). % Filename prefix. - --define(record_size, 512). --define(block_size, (512*20)). - - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%% -%%% Adding members to a tar archive. -%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -add1(TarFile, Bin, NameInArchive, Opts) when is_binary(Bin) -> - Now = calendar:now_to_local_time(erlang:timestamp()), - Info = #file_info{size = byte_size(Bin), - type = regular, - access = read_write, - atime = Now, - mtime = Now, - ctime = Now, - mode = 8#100644, - links = 1, - major_device = 0, - minor_device = 0, - inode = 0, - uid = 0, - gid = 0}, - Header = create_header(NameInArchive, Info), - add1(TarFile, NameInArchive, Header, Bin, Opts); -add1(TarFile, Name, NameInArchive, Opts) -> - case read_file_and_info(Name, Opts) of - {ok, Bin, Info} when Info#file_info.type =:= regular -> - Header = create_header(NameInArchive, Info), - add1(TarFile, Name, Header, Bin, Opts); - {ok, PointsTo, Info} when Info#file_info.type =:= symlink -> - if - length(PointsTo) > 100 -> - {error,{PointsTo,symbolic_link_too_long}}; - true -> - Info2 = Info#file_info{size=0}, - Header = create_header(NameInArchive, Info2, PointsTo), - add1(TarFile, Name, Header, list_to_binary([]), Opts) - end; - {ok, _, Info} when Info#file_info.type =:= directory -> - add_directory(TarFile, Name, NameInArchive, Info, Opts); - {ok, _, #file_info{type=Type}} -> - {error, {bad_file_type, Name, Type}}; - {error, Reason} -> - {error, {Name, Reason}} +pad_file(#reader{pos=Pos}=Reader) -> + %% There must be at least two zero blocks at the end. + PadCurrent = skip_padding(Pos+?BLOCK_SIZE), + Padding = <<0:PadCurrent/unit:8>>, + do_write(Reader, [Padding, ?ZERO_BLOCK, ?ZERO_BLOCK]). + + +%%%================================================================ +%% Creation/modification of tar archives + +%% Creates a tar file Name containing the given files. +-spec create(file:filename(), filelist()) -> ok | {error, {string(), term()}}. +create(Name, FileList) when is_list(Name); is_binary(Name) -> + create(Name, FileList, []). + +%% Creates a tar archive Name containing the given files. +%% Accepted options: verbose, compressed, cooked +-spec create(file:filename(), filelist(), [create_opt()]) -> + ok | {error, term()} | {error, {string(), term()}}. +create(Name, FileList, Options) when is_list(Name); is_binary(Name) -> + Mode = lists:filter(fun(X) -> (X=:=compressed) or (X=:=cooked) + end, Options), + case open(Name, [write|Mode]) of + {ok, TarFile} -> + do_create(TarFile, FileList, Options); + {error, _} = Err -> + Err end. -add1(Tar, Name, Header, chunked, Options) -> - add_verbose(Options, "a ~ts [chunked ", [Name]), - try - ok = do_write(Tar, Header), - {ok,D} = file:open(Name, [read,binary]), - {ok,NumBytes} = add_read_write_chunks(D, Tar, Options#add_opts.chunk_size, 0, Options), - _ = file:close(D), - ok = do_write(Tar, padding(NumBytes,?record_size)) - of - ok -> - add_verbose(Options, "~n", []), - ok - catch - error:{badmatch,{error,Error}} -> - add_verbose(Options, "~n", []), - {error,{Name,Error}} +do_create(TarFile, [], _Opts) -> + close(TarFile); +do_create(TarFile, [{NameInArchive, NameOrBin}|Rest], Opts) -> + case add(TarFile, NameOrBin, NameInArchive, Opts) of + ok -> + do_create(TarFile, Rest, Opts); + {error, _} = Err -> + _ = close(TarFile), + Err + end; +do_create(TarFile, [Name|Rest], Opts) -> + case add(TarFile, Name, Name, Opts) of + ok -> + do_create(TarFile, Rest, Opts); + {error, _} = Err -> + _ = close(TarFile), + Err + end. + +%% Adds a file to a tape archive. +-type add_type() :: string() + | {string(), string()} + | {string(), binary()}. +-spec add(reader(), add_type(), [add_opt()]) -> ok | {error, term()}. +add(Reader, {NameInArchive, Name}, Opts) + when is_list(NameInArchive), is_list(Name) -> + do_add(Reader, Name, NameInArchive, Opts); +add(Reader, {NameInArchive, Bin}, Opts) + when is_list(NameInArchive), is_binary(Bin) -> + do_add(Reader, Bin, NameInArchive, Opts); +add(Reader, Name, Opts) when is_list(Name) -> + do_add(Reader, Name, Name, Opts). + + +-spec add(reader(), string() | binary(), string(), [add_opt()]) -> + ok | {error, term()}. +add(Reader, NameOrBin, NameInArchive, Options) + when is_list(NameOrBin); is_binary(NameOrBin), + is_list(NameInArchive), is_list(Options) -> + do_add(Reader, NameOrBin, NameInArchive, Options). + +do_add(#reader{access=write}=Reader, Name, NameInArchive, Options) + when is_list(NameInArchive), is_list(Options) -> + RF = fun(F) -> file:read_link_info(F, [{time, posix}]) end, + Opts = #add_opts{read_info=RF}, + add1(Reader, Name, NameInArchive, add_opts(Options, Opts)); +do_add(#reader{access=read},_,_,_) -> + {error, eacces}; +do_add(Reader,_,_,_) -> + {error, {badarg, Reader}}. + +add_opts([dereference|T], Opts) -> + RF = fun(F) -> file:read_file_info(F, [{time, posix}]) end, + add_opts(T, Opts#add_opts{read_info=RF}); +add_opts([verbose|T], Opts) -> + add_opts(T, Opts#add_opts{verbose=true}); +add_opts([{chunks,N}|T], Opts) -> + add_opts(T, Opts#add_opts{chunk_size=N}); +add_opts([_|T], Opts) -> + add_opts(T, Opts); +add_opts([], Opts) -> + Opts. + +add1(#reader{}=Reader, Name, NameInArchive, #add_opts{read_info=ReadInfo}=Opts) + when is_list(Name) -> + Res = case ReadInfo(Name) of + {error, Reason0} -> + {error, {Name, Reason0}}; + {ok, #file_info{type=symlink}=Fi} -> + add_verbose(Opts, "a ~ts~n", [NameInArchive]), + {ok, Linkname} = file:read_link(Name), + Header = fileinfo_to_header(NameInArchive, Fi, Linkname), + add_header(Reader, Header, Opts); + {ok, #file_info{type=regular}=Fi} -> + add_verbose(Opts, "a ~ts~n", [NameInArchive]), + Header = fileinfo_to_header(NameInArchive, Fi, false), + {ok, Reader2} = add_header(Reader, Header, Opts), + FileSize = Header#tar_header.size, + {ok, FileSize, Reader3} = do_copy(Reader2, Name, Opts), + Padding = skip_padding(FileSize), + Pad = <<0:Padding/unit:8>>, + do_write(Reader3, Pad); + {ok, #file_info{type=directory}=Fi} -> + add_directory(Reader, Name, NameInArchive, Fi, Opts); + {ok, #file_info{}=Fi} -> + add_verbose(Opts, "a ~ts~n", [NameInArchive]), + Header = fileinfo_to_header(NameInArchive, Fi, false), + add_header(Reader, Header, Opts) + end, + case Res of + ok -> ok; + {ok, _Reader} -> ok; + {error, _Reason} = Err -> Err end; -add1(Tar, Name, Header, Bin, Options) -> - add_verbose(Options, "a ~ts~n", [Name]), - do_write(Tar, [Header, Bin, padding(byte_size(Bin), ?record_size)]). - -add_read_write_chunks(D, Tar, ChunkSize, SumNumBytes, Options) -> - case file:read(D, ChunkSize) of - {ok,Bin} -> - ok = do_write(Tar, Bin), - add_verbose(Options, ".", []), - add_read_write_chunks(D, Tar, ChunkSize, SumNumBytes+byte_size(Bin), Options); - eof -> - add_verbose(Options, "]", []), - {ok,SumNumBytes}; - Other -> - Other +add1(Reader, Bin, NameInArchive, Opts) when is_binary(Bin) -> + add_verbose(Opts, "a ~ts~n", [NameInArchive]), + Now = os:system_time(seconds), + Header = #tar_header{ + name = NameInArchive, + size = byte_size(Bin), + typeflag = ?TYPE_REGULAR, + atime = Now, + mtime = Now, + ctime = Now, + mode = 8#100644}, + {ok, Reader2} = add_header(Reader, Header, Opts), + Padding = skip_padding(byte_size(Bin)), + Data = [Bin, <<0:Padding/unit:8>>], + case do_write(Reader2, Data) of + {ok, _Reader3} -> ok; + {error, Reason} -> {error, {NameInArchive, Reason}} end. -add_directory(TarFile, DirName, NameInArchive, Info, Options) -> +add_directory(Reader, DirName, NameInArchive, Info, Opts) -> case file:list_dir(DirName) of - {ok, []} -> - add_verbose(Options, "a ~ts~n", [DirName]), - Header = create_header(NameInArchive, Info), - do_write(TarFile, Header); - {ok, Files} -> - Add = fun (File) -> - add1(TarFile, - filename:join(DirName, File), - filename:join(NameInArchive, File), - Options) end, - foreach_while_ok(Add, Files); - {error, Reason} -> - {error, {DirName, Reason}} + {ok, []} -> + add_verbose(Opts, "a ~ts~n", [NameInArchive]), + Header = fileinfo_to_header(NameInArchive, Info, false), + add_header(Reader, Header, Opts); + {ok, Files} -> + add_verbose(Opts, "a ~ts~n", [NameInArchive]), + try add_files(Reader, Files, DirName, NameInArchive, Opts) of + ok -> ok; + {error, _} = Err -> Err + catch + throw:{error, {_Name, _Reason}} = Err -> Err; + throw:{error, Reason} -> {error, {DirName, Reason}} + end; + {error, Reason} -> + {error, {DirName, Reason}} end. - -%% Creates a header for file in a tar file. - -create_header(Name, Info) -> - create_header(Name, Info, []). -create_header(Name, #file_info {mode=Mode, uid=Uid, gid=Gid, - size=Size, mtime=Mtime0, type=Type}, Linkname) -> - Mtime = posix_time(erlang:localtime_to_universaltime(Mtime0)), - {Prefix,Suffix} = split_filename(Name), - H0 = [to_string(Suffix, 100), - to_octal(Mode, 8), - to_octal(Uid, 8), - to_octal(Gid, 8), - to_octal(Size, ?th_size_len), - to_octal(Mtime, ?th_mtime_len), - <<" ">>, - file_type(Type), - to_string(Linkname, ?th_linkname_len), - "ustar",0, - "00", - zeroes(?th_prefix-?th_version-?th_version_len), - to_string(Prefix, ?th_prefix_len)], - H = list_to_binary(H0), - 512 = byte_size(H), %Assertion. - ChksumString = to_octal(checksum(H), 6, [0,$\s]), - <<Before:?th_chksum/binary,_:?th_chksum_len/binary,After/binary>> = H, - [Before,ChksumString,After]. - -file_type(regular) -> $0; -file_type(symlink) -> $2; -file_type(directory) -> $5. - -to_octal(Int, Count) when Count > 1 -> - to_octal(Int, Count-1, [0]). - -to_octal(_, 0, Result) -> Result; -to_octal(Int, Count, Result) -> - to_octal(Int div 8, Count-1, [Int rem 8 + $0|Result]). - -to_string(Str0, Count) -> - Str = case file:native_name_encoding() of - utf8 -> - unicode:characters_to_binary(Str0); - latin1 -> - list_to_binary(Str0) - end, - case byte_size(Str) of - Size when Size < Count -> - [Str|zeroes(Count-Size)]; - _ -> Str + +add_files(_Reader, [], _Dir, _DirInArchive, _Opts) -> + ok; +add_files(Reader, [Name|Rest], Dir, DirInArchive, #add_opts{read_info=Info}=Opts) -> + FullName = filename:join(Dir, Name), + NameInArchive = filename:join(DirInArchive, Name), + Res = case Info(FullName) of + {error, Reason} -> + {error, {FullName, Reason}}; + {ok, #file_info{type=directory}=Fi} -> + add_directory(Reader, FullName, NameInArchive, Fi, Opts); + {ok, #file_info{type=symlink}=Fi} -> + add_verbose(Opts, "a ~ts~n", [NameInArchive]), + {ok, Linkname} = file:read_link(FullName), + Header = fileinfo_to_header(NameInArchive, Fi, Linkname), + add_header(Reader, Header, Opts); + {ok, #file_info{type=regular}=Fi} -> + add_verbose(Opts, "a ~ts~n", [NameInArchive]), + Header = fileinfo_to_header(NameInArchive, Fi, false), + {ok, Reader2} = add_header(Reader, Header, Opts), + FileSize = Header#tar_header.size, + {ok, FileSize, Reader3} = do_copy(Reader2, FullName, Opts), + Padding = skip_padding(FileSize), + Pad = <<0:Padding/unit:8>>, + do_write(Reader3, Pad); + {ok, #file_info{}=Fi} -> + add_verbose(Opts, "a ~ts~n", [NameInArchive]), + Header = fileinfo_to_header(NameInArchive, Fi, false), + add_header(Reader, Header, Opts) + end, + case Res of + ok -> add_files(Reader, Rest, Dir, DirInArchive, Opts); + {ok, ReaderNext} -> add_files(ReaderNext, Rest, Dir, DirInArchive, Opts); + {error, _} = Err -> Err end. -%% Pads out end of file. - -pad_file(File) -> - {ok,Position} = do_position(File, {cur,0}), - %% There must be at least two zero records at the end. - Fill = case ?block_size - (Position rem ?block_size) of - Fill0 when Fill0 < 2*?record_size -> - %% We need to another block here to ensure that there - %% are at least two zero records at the end. - Fill0 + ?block_size; - Fill0 -> - %% Large enough. - Fill0 - end, - do_write(File, zeroes(Fill)). - -split_filename(Name) when length(Name) =< ?th_name_len -> - {"", Name}; -split_filename(Name0) -> - split_filename(lists:reverse(filename:split(Name0)), [], [], 0). - -split_filename([Comp|Rest], Prefix, Suffix, Len) - when Len+length(Comp) < ?th_name_len -> - split_filename(Rest, Prefix, [Comp|Suffix], Len+length(Comp)+1); -split_filename([Comp|Rest], Prefix, Suffix, Len) -> - split_filename(Rest, [Comp|Prefix], Suffix, Len+length(Comp)+1); -split_filename([], Prefix, Suffix, _) -> - {filename:join(Prefix),filename:join(Suffix)}. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%% -%%% Retrieving files from a tape archive. -%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -%% Options used when reading a tar archive. - --record(read_opts, - {cwd :: string(), % Current working directory. - keep_old_files = false :: boolean(), % Owerwrite or not. - files = all, % Set of files to extract - % (or all). - output = file :: 'file' | 'memory', - open_mode = [], % Open mode options. - verbose = false :: boolean()}). % Verbose on/off. +format_string(String, Size) when length(String) > Size -> + throw({error, {write_string, field_too_long}}); +format_string(String, Size) -> + Ascii = to_ascii(String), + if byte_size(Ascii) < Size -> + [Ascii, 0]; + true -> + Ascii + end. -extract_opts(List) -> - extract_opts(List, default_options()). +format_octal(Octal) -> + iolist_to_binary(io_lib:fwrite("~.8B", [Octal])). + +add_header(#reader{}=Reader, #tar_header{}=Header, Opts) -> + {ok, Iodata} = build_header(Header, Opts), + do_write(Reader, Iodata). + +write_to_block(Block, IoData, Start) when is_list(IoData) -> + write_to_block(Block, iolist_to_binary(IoData), Start); +write_to_block(Block, Bin, Start) when is_binary(Bin) -> + Size = byte_size(Bin), + <<Head:Start/unit:8, _:Size/unit:8, Rest/binary>> = Block, + <<Head:Start/unit:8, Bin/binary, Rest/binary>>. + +build_header(#tar_header{}=Header, Opts) -> + #tar_header{ + name=Name, + mode=Mode, + uid=Uid, + gid=Gid, + size=Size, + typeflag=Type, + linkname=Linkname, + uname=Uname, + gname=Gname, + devmajor=Devmaj, + devminor=Devmin + } = Header, + Mtime = Header#tar_header.mtime, + + Block0 = ?ZERO_BLOCK, + {Block1, Pax0} = write_string(Block0, ?V7_NAME, ?V7_NAME_LEN, Name, ?PAX_PATH, #{}), + Block2 = write_octal(Block1, ?V7_MODE, ?V7_MODE_LEN, Mode), + {Block3, Pax1} = write_numeric(Block2, ?V7_UID, ?V7_UID_LEN, Uid, ?PAX_UID, Pax0), + {Block4, Pax2} = write_numeric(Block3, ?V7_GID, ?V7_GID_LEN, Gid, ?PAX_GID, Pax1), + {Block5, Pax3} = write_numeric(Block4, ?V7_SIZE, ?V7_SIZE_LEN, Size, ?PAX_SIZE, Pax2), + {Block6, Pax4} = write_numeric(Block5, ?V7_MTIME, ?V7_MTIME_LEN, Mtime, ?PAX_NONE, Pax3), + {Block7, Pax5} = write_string(Block6, ?V7_TYPE, ?V7_TYPE_LEN, <<Type>>, ?PAX_NONE, Pax4), + {Block8, Pax6} = write_string(Block7, ?V7_LINKNAME, ?V7_LINKNAME_LEN, + Linkname, ?PAX_LINKPATH, Pax5), + {Block9, Pax7} = write_string(Block8, ?USTAR_UNAME, ?USTAR_UNAME_LEN, + Uname, ?PAX_UNAME, Pax6), + {Block10, Pax8} = write_string(Block9, ?USTAR_GNAME, ?USTAR_GNAME_LEN, + Gname, ?PAX_GNAME, Pax7), + {Block11, Pax9} = write_numeric(Block10, ?USTAR_DEVMAJ, ?USTAR_DEVMAJ_LEN, + Devmaj, ?PAX_NONE, Pax8), + {Block12, Pax10} = write_numeric(Block11, ?USTAR_DEVMIN, ?USTAR_DEVMIN_LEN, + Devmin, ?PAX_NONE, Pax9), + {Block13, Pax11} = set_path(Block12, Pax10), + PaxEntry = case maps:size(Pax11) of + 0 -> []; + _ -> build_pax_entry(Header, Pax11, Opts) + end, + Block14 = set_format(Block13, ?FORMAT_USTAR), + Block15 = set_checksum(Block14), + {ok, [PaxEntry, Block15]}. + +set_path(Block0, Pax) -> + %% only use ustar header when name is too long + case maps:get(?PAX_PATH, Pax, nil) of + nil -> + {Block0, Pax}; + PaxPath -> + case split_ustar_path(PaxPath) of + {ok, UstarName, UstarPrefix} -> + {Block1, _} = write_string(Block0, ?V7_NAME, ?V7_NAME_LEN, + UstarName, ?PAX_NONE, #{}), + {Block2, _} = write_string(Block1, ?USTAR_PREFIX, ?USTAR_PREFIX_LEN, + UstarPrefix, ?PAX_NONE, #{}), + {Block2, maps:remove(?PAX_PATH, Pax)}; + false -> + {Block0, Pax} + end + end. -table_opts(List) -> - read_opts(List, default_options()). +set_format(Block0, Format) + when Format =:= ?FORMAT_USTAR; Format =:= ?FORMAT_PAX -> + Block1 = write_to_block(Block0, ?MAGIC_USTAR, ?USTAR_MAGIC), + write_to_block(Block1, ?VERSION_USTAR, ?USTAR_VERSION); +set_format(_Block, Format) -> + throw({error, {invalid_format, Format}}). + +set_checksum(Block) -> + Checksum = compute_checksum(Block), + write_octal(Block, ?V7_CHKSUM, ?V7_CHKSUM_LEN, Checksum). + +build_pax_entry(Header, PaxAttrs, Opts) -> + Path = Header#tar_header.name, + Filename = filename:basename(Path), + Dir = filename:dirname(Path), + Path2 = filename:join([Dir, "PaxHeaders.0", Filename]), + AsciiPath = to_ascii(Path2), + Path3 = if byte_size(AsciiPath) > ?V7_NAME_LEN -> + binary_part(AsciiPath, 0, ?V7_NAME_LEN - 1); + true -> + AsciiPath + end, + Keys = maps:keys(PaxAttrs), + SortedKeys = lists:sort(Keys), + PaxFile = build_pax_file(SortedKeys, PaxAttrs), + Size = byte_size(PaxFile), + Padding = (?BLOCK_SIZE - + (byte_size(PaxFile) rem ?BLOCK_SIZE)) rem ?BLOCK_SIZE, + Pad = <<0:Padding/unit:8>>, + PaxHeader = #tar_header{ + name=unicode:characters_to_list(Path3), + size=Size, + mtime=Header#tar_header.mtime, + atime=Header#tar_header.atime, + ctime=Header#tar_header.ctime, + typeflag=?TYPE_X_HEADER + }, + {ok, PaxHeaderData} = build_header(PaxHeader, Opts), + [PaxHeaderData, PaxFile, Pad]. + +build_pax_file(Keys, PaxAttrs) -> + build_pax_file(Keys, PaxAttrs, []). +build_pax_file([], _, Acc) -> + unicode:characters_to_binary(Acc); +build_pax_file([K|Rest], Attrs, Acc) -> + V = maps:get(K, Attrs), + Size = sizeof(K) + sizeof(V) + 3, + Size2 = sizeof(Size) + Size, + Key = to_string(K), + Value = to_string(V), + Record = unicode:characters_to_binary(io_lib:format("~B ~ts=~ts\n", [Size2, Key, Value])), + if byte_size(Record) =/= Size2 -> + Size3 = byte_size(Record), + Record2 = io_lib:format("~B ~ts=~ts\n", [Size3, Key, Value]), + build_pax_file(Rest, Attrs, [Acc, Record2]); + true -> + build_pax_file(Rest, Attrs, [Acc, Record]) + end. -default_options() -> - {ok, Cwd} = file:get_cwd(), - #read_opts{cwd=Cwd}. +sizeof(Bin) when is_binary(Bin) -> + byte_size(Bin); +sizeof(List) when is_list(List) -> + length(List); +sizeof(N) when is_integer(N) -> + byte_size(integer_to_binary(N)); +sizeof(N) when is_float(N) -> + byte_size(float_to_binary(N)). + +to_string(Bin) when is_binary(Bin) -> + unicode:characters_to_list(Bin); +to_string(List) when is_list(List) -> + List; +to_string(N) when is_integer(N) -> + integer_to_list(N); +to_string(N) when is_float(N) -> + float_to_list(N). + +split_ustar_path(Path) -> + Len = length(Path), + NotAscii = not is_ascii(Path), + if Len =< ?V7_NAME_LEN; NotAscii -> + false; + true -> + PathBin = binary:list_to_bin(Path), + case binary:split(PathBin, [<<$/>>], [global, trim_all]) of + [Part] when byte_size(Part) >= ?V7_NAME_LEN -> + false; + Parts -> + case lists:last(Parts) of + Name when byte_size(Name) >= ?V7_NAME_LEN -> + false; + Name -> + Parts2 = lists:sublist(Parts, length(Parts) - 1), + join_split_ustar_path(Parts2, {ok, Name, nil}) + end + end + end. -%% Parse options for extract. +join_split_ustar_path([], Acc) -> + Acc; +join_split_ustar_path([Part|_], {ok, _, nil}) + when byte_size(Part) > ?USTAR_PREFIX_LEN -> + false; +join_split_ustar_path([Part|_], {ok, _Name, Acc}) + when (byte_size(Part)+byte_size(Acc)) > ?USTAR_PREFIX_LEN -> + false; +join_split_ustar_path([Part|Rest], {ok, Name, nil}) -> + join_split_ustar_path(Rest, {ok, Name, Part}); +join_split_ustar_path([Part|Rest], {ok, Name, Acc}) -> + join_split_ustar_path(Rest, {ok, Name, <<Acc/binary,$/,Part/binary>>}). + +write_octal(Block, Pos, Size, X) -> + Octal = zero_pad(format_octal(X), Size-1), + if byte_size(Octal) < Size -> + write_to_block(Block, Octal, Pos); + true -> + throw({error, {write_failed, octal_field_too_long}}) + end. -extract_opts([keep_old_files|Rest], Opts) -> - extract_opts(Rest, Opts#read_opts{keep_old_files=true}); -extract_opts([{cwd, Cwd}|Rest], Opts) -> - extract_opts(Rest, Opts#read_opts{cwd=Cwd}); -extract_opts([{files, Files}|Rest], Opts) -> - Set = ordsets:from_list(Files), - extract_opts(Rest, Opts#read_opts{files=Set}); -extract_opts([memory|Rest], Opts) -> - extract_opts(Rest, Opts#read_opts{output=memory}); -extract_opts([compressed|Rest], Opts=#read_opts{open_mode=OpenMode}) -> - extract_opts(Rest, Opts#read_opts{open_mode=[compressed|OpenMode]}); -extract_opts([cooked|Rest], Opts=#read_opts{open_mode=OpenMode}) -> - extract_opts(Rest, Opts#read_opts{open_mode=[cooked|OpenMode]}); -extract_opts([verbose|Rest], Opts) -> - extract_opts(Rest, Opts#read_opts{verbose=true}); -extract_opts([Other|Rest], Opts) -> - extract_opts(Rest, read_opts([Other], Opts)); -extract_opts([], Opts) -> - Opts. +write_string(Block, Pos, Size, Str, PaxAttr, Pax0) -> + NotAscii = not is_ascii(Str), + if PaxAttr =/= ?PAX_NONE andalso (length(Str) > Size orelse NotAscii) -> + Pax1 = maps:put(PaxAttr, Str, Pax0), + {Block, Pax1}; + true -> + Formatted = format_string(Str, Size), + {write_to_block(Block, Formatted, Pos), Pax0} + end. +write_numeric(Block, Pos, Size, X, PaxAttr, Pax0) -> + %% attempt octal + Octal = zero_pad(format_octal(X), Size-1), + if byte_size(Octal) < Size -> + {write_to_block(Block, [Octal, 0], Pos), Pax0}; + PaxAttr =/= ?PAX_NONE -> + Pax1 = maps:put(PaxAttr, X, Pax0), + {Block, Pax1}; + true -> + throw({error, {write_failed, numeric_field_too_long}}) + end. -%% Common options for all read operations. +zero_pad(Str, Size) when byte_size(Str) >= Size -> + Str; +zero_pad(Str, Size) -> + Padding = Size - byte_size(Str), + Pad = binary:copy(<<$0>>, Padding), + <<Pad/binary, Str/binary>>. -read_opts([compressed|Rest], Opts=#read_opts{open_mode=OpenMode}) -> - read_opts(Rest, Opts#read_opts{open_mode=[compressed|OpenMode]}); -read_opts([cooked|Rest], Opts=#read_opts{open_mode=OpenMode}) -> - read_opts(Rest, Opts#read_opts{open_mode=[cooked|OpenMode]}); -read_opts([verbose|Rest], Opts) -> - read_opts(Rest, Opts#read_opts{verbose=true}); -read_opts([_|Rest], Opts) -> - read_opts(Rest, Opts); -read_opts([], Opts) -> - Opts. -foldl_read({AccessMode,TD={tar_descriptor,_UsrHandle,_AccessFun}}, Fun, Accu, Opts) -> - case AccessMode of - read -> - foldl_read0(TD, Fun, Accu, Opts); - _ -> - {error,{read_mode_expected,AccessMode}} - end; -foldl_read(TarName, Fun, Accu, Opts) -> - case open(TarName, [read|Opts#read_opts.open_mode]) of - {ok, {read, File}} -> - Result = foldl_read0(File, Fun, Accu, Opts), - ok = do_close(File), - Result; - Error -> - Error +%%%================================================================ +%% Functions for creating or modifying tar archives + +read_block(Reader) -> + case do_read(Reader, ?BLOCK_SIZE) of + eof -> + throw({error, eof}); + %% Two zero blocks mark the end of the archive + {ok, ?ZERO_BLOCK, Reader1} -> + case do_read(Reader1, ?BLOCK_SIZE) of + eof -> + % This is technically a malformed end-of-archive marker, + % as two ZERO_BLOCKs are expected as the marker, + % but if we've already made it this far, we should just ignore it + eof; + {ok, ?ZERO_BLOCK, _Reader2} -> + eof; + {ok, _Block, _Reader2} -> + throw({error, invalid_end_of_archive}); + {error,_} = Err -> + throw(Err) + end; + {ok, Block, Reader1} when is_binary(Block) -> + {ok, Block, Reader1}; + {error, _} = Err -> + throw(Err) end. -foldl_read0(File, Fun, Accu, Opts) -> - case catch foldl_read1(Fun, Accu, File, Opts) of - {'EXIT', Reason} -> - exit(Reason); - {error, {Reason, Format, Args}} -> - read_verbose(Opts, Format, Args), - {error, Reason}; - {error, Reason} -> - {error, Reason}; - Ok -> - Ok +get_header(#reader{}=Reader) -> + case read_block(Reader) of + eof -> + eof; + {ok, Block, Reader1} -> + convert_header(Block, Reader1) end. -foldl_read1(Fun, Accu0, File, Opts) -> - case get_header(File) of - eof -> - Fun(eof, File, Opts, Accu0); - Header -> - {ok, NewAccu} = Fun(Header, File, Opts, Accu0), - foldl_read1(Fun, NewAccu, File, Opts) +%% Converts the tar header to a record. +to_v7(Bin) when is_binary(Bin), byte_size(Bin) =:= ?BLOCK_SIZE -> + #header_v7{ + name=binary_part(Bin, ?V7_NAME, ?V7_NAME_LEN), + mode=binary_part(Bin, ?V7_MODE, ?V7_MODE_LEN), + uid=binary_part(Bin, ?V7_UID, ?V7_UID_LEN), + gid=binary_part(Bin, ?V7_GID, ?V7_GID_LEN), + size=binary_part(Bin, ?V7_SIZE, ?V7_SIZE_LEN), + mtime=binary_part(Bin, ?V7_MTIME, ?V7_MTIME_LEN), + checksum=binary_part(Bin, ?V7_CHKSUM, ?V7_CHKSUM_LEN), + typeflag=binary:at(Bin, ?V7_TYPE), + linkname=binary_part(Bin, ?V7_LINKNAME, ?V7_LINKNAME_LEN) + }; +to_v7(_) -> + {error, header_block_too_small}. + +to_gnu(#header_v7{}=V7, Bin) + when is_binary(Bin), byte_size(Bin) =:= ?BLOCK_SIZE -> + #header_gnu{ + header_v7=V7, + magic=binary_part(Bin, ?GNU_MAGIC, ?GNU_MAGIC_LEN), + version=binary_part(Bin, ?GNU_VERSION, ?GNU_VERSION_LEN), + uname=binary_part(Bin, 265, 32), + gname=binary_part(Bin, 297, 32), + devmajor=binary_part(Bin, 329, 8), + devminor=binary_part(Bin, 337, 8), + atime=binary_part(Bin, 345, 12), + ctime=binary_part(Bin, 357, 12), + sparse=to_sparse_array(binary_part(Bin, 386, 24*4+1)), + real_size=binary_part(Bin, 483, 12) + }. + +to_star(#header_v7{}=V7, Bin) + when is_binary(Bin), byte_size(Bin) =:= ?BLOCK_SIZE -> + #header_star{ + header_v7=V7, + magic=binary_part(Bin, ?USTAR_MAGIC, ?USTAR_MAGIC_LEN), + version=binary_part(Bin, ?USTAR_VERSION, ?USTAR_VERSION_LEN), + uname=binary_part(Bin, ?USTAR_UNAME, ?USTAR_UNAME_LEN), + gname=binary_part(Bin, ?USTAR_GNAME, ?USTAR_GNAME_LEN), + devmajor=binary_part(Bin, ?USTAR_DEVMAJ, ?USTAR_DEVMAJ_LEN), + devminor=binary_part(Bin, ?USTAR_DEVMIN, ?USTAR_DEVMIN_LEN), + prefix=binary_part(Bin, 345, 131), + atime=binary_part(Bin, 476, 12), + ctime=binary_part(Bin, 488, 12), + trailer=binary_part(Bin, ?STAR_TRAILER, ?STAR_TRAILER_LEN) + }. + +to_ustar(#header_v7{}=V7, Bin) + when is_binary(Bin), byte_size(Bin) =:= ?BLOCK_SIZE -> + #header_ustar{ + header_v7=V7, + magic=binary_part(Bin, ?USTAR_MAGIC, ?USTAR_MAGIC_LEN), + version=binary_part(Bin, ?USTAR_VERSION, ?USTAR_VERSION_LEN), + uname=binary_part(Bin, ?USTAR_UNAME, ?USTAR_UNAME_LEN), + gname=binary_part(Bin, ?USTAR_GNAME, ?USTAR_GNAME_LEN), + devmajor=binary_part(Bin, ?USTAR_DEVMAJ, ?USTAR_DEVMAJ_LEN), + devminor=binary_part(Bin, ?USTAR_DEVMIN, ?USTAR_DEVMIN_LEN), + prefix=binary_part(Bin, 345, 155) + }. + +to_sparse_array(Bin) when is_binary(Bin) -> + MaxEntries = byte_size(Bin) div 24, + IsExtended = 1 =:= binary:at(Bin, 24*MaxEntries), + Entries = parse_sparse_entries(Bin, MaxEntries-1, []), + #sparse_array{ + entries=Entries, + max_entries=MaxEntries, + is_extended=IsExtended + }. + +parse_sparse_entries(<<>>, _, Acc) -> + Acc; +parse_sparse_entries(_, -1, Acc) -> + Acc; +parse_sparse_entries(Bin, N, Acc) -> + case to_sparse_entry(binary_part(Bin, N*24, 24)) of + nil -> + parse_sparse_entries(Bin, N-1, Acc); + Entry = #sparse_entry{} -> + parse_sparse_entries(Bin, N-1, [Entry|Acc]) end. -table1(eof, _, _, Result) -> - {ok, lists:reverse(Result)}; -table1(Header = #tar_header{}, File, #read_opts{verbose=true}, Result) -> - #tar_header{name=Name, size=Size, mtime=Mtime, typeflag=Type, - mode=Mode, uid=Uid, gid=Gid} = Header, - skip(File, Size), - {ok, [{Name, Type, Size, posix_to_erlang_time(Mtime), Mode, Uid, Gid}|Result]}; -table1(#tar_header{name=Name, size=Size}, File, _, Result) -> - skip(File, Size), - {ok, [Name|Result]}. - -extract1(eof, _, _, Acc) -> - if - is_list(Acc) -> - {ok, lists:reverse(Acc)}; - true -> - Acc - end; -extract1(Header, File, Opts, Acc) -> - Name = Header#tar_header.name, - case check_extract(Name, Opts) of - true -> - {ok, Bin} = get_element(File, Header), - case write_extracted_element(Header, Bin, Opts) of - ok -> - {ok, Acc}; - {ok, NameBin} when is_list(Acc) -> - {ok, [NameBin | Acc]}; - {ok, NameBin} when Acc =:= ok -> - {ok, [NameBin]} - end; - false -> - ok = skip(File, Header#tar_header.size), - {ok, Acc} +-define(EMPTY_ENTRY, <<0,0,0,0,0,0,0,0,0,0,0,0>>). +to_sparse_entry(Bin) when is_binary(Bin), byte_size(Bin) =:= 24 -> + OffsetBin = binary_part(Bin, 0, 12), + NumBytesBin = binary_part(Bin, 12, 12), + case {OffsetBin, NumBytesBin} of + {?EMPTY_ENTRY, ?EMPTY_ENTRY} -> + nil; + _ -> + #sparse_entry{ + offset=parse_numeric(OffsetBin), + num_bytes=parse_numeric(NumBytesBin)} end. -%% Checks if the file Name should be extracted. +-spec get_format(binary()) -> {ok, pos_integer(), header_v7()} + | ?FORMAT_UNKNOWN + | {error, term()}. +get_format(Bin) when is_binary(Bin), byte_size(Bin) =:= ?BLOCK_SIZE -> + do_get_format(to_v7(Bin), Bin). + +do_get_format({error, _} = Err, _Bin) -> + Err; +do_get_format(#header_v7{}=V7, Bin) + when is_binary(Bin), byte_size(Bin) =:= ?BLOCK_SIZE -> + Checksum = parse_octal(V7#header_v7.checksum), + Chk1 = compute_checksum(Bin), + Chk2 = compute_signed_checksum(Bin), + if Checksum =/= Chk1 andalso Checksum =/= Chk2 -> + ?FORMAT_UNKNOWN; + true -> + %% guess magic + Ustar = to_ustar(V7, Bin), + Star = to_star(V7, Bin), + Magic = Ustar#header_ustar.magic, + Version = Ustar#header_ustar.version, + Trailer = Star#header_star.trailer, + Format = if + Magic =:= ?MAGIC_USTAR, Trailer =:= ?TRAILER_STAR -> + ?FORMAT_STAR; + Magic =:= ?MAGIC_USTAR -> + ?FORMAT_USTAR; + Magic =:= ?MAGIC_GNU, Version =:= ?VERSION_GNU -> + ?FORMAT_GNU; + true -> + ?FORMAT_V7 + end, + {ok, Format, V7} + end. -check_extract(_, #read_opts{files=all}) -> +unpack_format(Format, #header_v7{}=V7, Bin, Reader) + when is_binary(Bin), byte_size(Bin) =:= ?BLOCK_SIZE -> + Mtime = parse_numeric(V7#header_v7.mtime), + Header0 = #tar_header{ + name=parse_string(V7#header_v7.name), + mode=parse_numeric(V7#header_v7.mode), + uid=parse_numeric(V7#header_v7.uid), + gid=parse_numeric(V7#header_v7.gid), + size=parse_numeric(V7#header_v7.size), + mtime=Mtime, + atime=Mtime, + ctime=Mtime, + typeflag=V7#header_v7.typeflag, + linkname=parse_string(V7#header_v7.linkname) + }, + Typeflag = Header0#tar_header.typeflag, + Header1 = if Format > ?FORMAT_V7 -> + unpack_modern(Format, V7, Bin, Header0); + true -> + Name = Header0#tar_header.name, + Header0#tar_header{name=safe_join_path("", Name)} + end, + HeaderOnly = is_header_only_type(Typeflag), + Header2 = if HeaderOnly -> + Header1#tar_header{size=0}; + true -> + Header1 + end, + if Typeflag =:= ?TYPE_GNU_SPARSE -> + Gnu = to_gnu(V7, Bin), + RealSize = parse_numeric(Gnu#header_gnu.real_size), + {Sparsemap, Reader2} = parse_sparse_map(Gnu, Reader), + Header3 = Header2#tar_header{size=RealSize}, + {Header3, new_sparse_file_reader(Reader2, Sparsemap, RealSize)}; + true -> + FileReader = #reg_file_reader{ + handle=Reader, + num_bytes=Header2#tar_header.size, + size=Header2#tar_header.size, + pos = 0 + }, + {Header2, FileReader} + end. + +unpack_modern(Format, #header_v7{}=V7, Bin, #tar_header{}=Header0) + when is_binary(Bin) -> + Typeflag = Header0#tar_header.typeflag, + Ustar = to_ustar(V7, Bin), + H0 = Header0#tar_header{ + uname=parse_string(Ustar#header_ustar.uname), + gname=parse_string(Ustar#header_ustar.gname)}, + H1 = if Typeflag =:= ?TYPE_CHAR + orelse Typeflag =:= ?TYPE_BLOCK -> + Ma = parse_numeric(Ustar#header_ustar.devmajor), + Mi = parse_numeric(Ustar#header_ustar.devminor), + H0#tar_header{ + devmajor=Ma, + devminor=Mi + }; + true -> + H0 + end, + {Prefix, H2} = case Format of + ?FORMAT_USTAR -> + {parse_string(Ustar#header_ustar.prefix), H1}; + ?FORMAT_STAR -> + Star = to_star(V7, Bin), + Prefix0 = parse_string(Star#header_star.prefix), + Atime0 = Star#header_star.atime, + Atime = parse_numeric(Atime0), + Ctime0 = Star#header_star.ctime, + Ctime = parse_numeric(Ctime0), + {Prefix0, H1#tar_header{ + atime=Atime, + ctime=Ctime + }}; + _ -> + {"", H1} + end, + Name = H2#tar_header.name, + H2#tar_header{name=safe_join_path(Prefix, Name)}. + + +safe_join_path([], Name) -> + filename:join([Name]); +safe_join_path(Prefix, []) -> + filename:join([Prefix]); +safe_join_path(Prefix, Name) -> + filename:join(Prefix, Name). + +new_sparse_file_reader(Reader, Sparsemap, RealSize) -> + true = validate_sparse_entries(Sparsemap, RealSize), + #sparse_file_reader{ + handle = Reader, + num_bytes = RealSize, + pos = 0, + size = RealSize, + sparse_map = Sparsemap}. + +validate_sparse_entries(Entries, RealSize) -> + validate_sparse_entries(Entries, RealSize, 0, 0). +validate_sparse_entries([], _RealSize, _I, _LastOffset) -> true; -check_extract(Name, #read_opts{files=Files}) -> - ordsets:is_element(Name, Files). +validate_sparse_entries([#sparse_entry{}=Entry|Rest], RealSize, I, LastOffset) -> + Offset = Entry#sparse_entry.offset, + NumBytes = Entry#sparse_entry.num_bytes, + if + Offset > ?MAX_INT64-NumBytes -> + throw({error, {invalid_sparse_map_entry, offset_too_large}}); + Offset+NumBytes > RealSize -> + throw({error, {invalid_sparse_map_entry, offset_too_large}}); + I > 0 andalso LastOffset > Offset -> + throw({error, {invalid_sparse_map_entry, overlapping_offsets}}); + true -> + ok + end, + validate_sparse_entries(Rest, RealSize, I+1, Offset+NumBytes). + + +-spec parse_sparse_map(header_gnu(), reader_type()) -> + {[sparse_entry()], reader_type()}. +parse_sparse_map(#header_gnu{sparse=Sparse}, Reader) + when Sparse#sparse_array.is_extended -> + parse_sparse_map(Sparse, Reader, []); +parse_sparse_map(#header_gnu{sparse=Sparse}, Reader) -> + {Sparse#sparse_array.entries, Reader}. +parse_sparse_map(#sparse_array{is_extended=true,entries=Entries}, Reader, Acc) -> + case read_block(Reader) of + eof -> + throw({error, eof}); + {ok, Block, Reader2} -> + Sparse2 = to_sparse_array(Block), + parse_sparse_map(Sparse2, Reader2, Entries++Acc) + end; +parse_sparse_map(#sparse_array{entries=Entries}, Reader, Acc) -> + Sorted = lists:sort(fun (#sparse_entry{offset=A},#sparse_entry{offset=B}) -> + A =< B + end, Entries++Acc), + {Sorted, Reader}. + +%% Defined by taking the sum of the unsigned byte values of the +%% entire header record, treating the checksum bytes to as ASCII spaces +compute_checksum(<<H1:?V7_CHKSUM/binary, + H2:?V7_CHKSUM_LEN/binary, + Rest:(?BLOCK_SIZE - ?V7_CHKSUM - ?V7_CHKSUM_LEN)/binary, + _/binary>>) -> + C0 = checksum(H1) + (byte_size(H2) * $\s), + C1 = checksum(Rest), + C0 + C1. + +compute_signed_checksum(<<H1:?V7_CHKSUM/binary, + H2:?V7_CHKSUM_LEN/binary, + Rest:(?BLOCK_SIZE - ?V7_CHKSUM - ?V7_CHKSUM_LEN)/binary, + _/binary>>) -> + C0 = signed_checksum(H1) + (byte_size(H2) * $\s), + C1 = signed_checksum(Rest), + C0 + C1. -get_header(File) -> - case do_read(File, ?record_size) of - eof -> - throw({error,eof}); - {ok, Bin} when is_binary(Bin) -> - convert_header(Bin); - {ok, List} -> - convert_header(list_to_binary(List)); - {error, Reason} -> - throw({error, Reason}) - end. +%% Returns the checksum of a binary. +checksum(Bin) -> checksum(Bin, 0). +checksum(<<A/unsigned,Rest/binary>>, Sum) -> + checksum(Rest, Sum+A); +checksum(<<>>, Sum) -> Sum. -%% Converts the tar header to a record. +signed_checksum(Bin) -> signed_checksum(Bin, 0). +signed_checksum(<<A/signed,Rest/binary>>, Sum) -> + signed_checksum(Rest, Sum+A); +signed_checksum(<<>>, Sum) -> Sum. + +-spec parse_numeric(binary()) -> non_neg_integer(). +parse_numeric(<<>>) -> + 0; +parse_numeric(<<First, _/binary>> = Bin) -> + %% check for base-256 format first + %% if the bit is set, then all following bits constitute a two's + %% complement encoded number in big-endian byte order + if + First band 16#80 =/= 0 -> + %% Handling negative numbers relies on the following identity: + %% -a-1 == ^a + %% If the number is negative, we use an inversion mask to invert + %% the data bytes and treat the value as an unsigned number + Inv = if First band 16#40 =/= 0 -> 16#00; true -> 16#FF end, + Bytes = binary:bin_to_list(Bin), + Reducer = fun (C, {I, X}) -> + C1 = C bxor Inv, + C2 = if I =:= 0 -> C1 band 16#7F; true -> C1 end, + if (X bsr 56) > 0 -> + throw({error,integer_overflow}); + true -> + {I+1, (X bsl 8) bor C2} + end + end, + {_, N} = lists:foldl(Reducer, {0,0}, Bytes), + if (N bsr 63) > 0 -> + throw({error, integer_overflow}); + true -> + if Inv =:= 16#FF -> + -1 bxor N; + true -> + N + end + end; + true -> + %% normal case is an octal number + parse_octal(Bin) + end. -convert_header(Bin) when byte_size(Bin) =:= ?record_size -> - case verify_checksum(Bin) of - ok -> - Hd = #tar_header{name=get_name(Bin), - mode=from_octal(Bin, ?th_mode, ?th_mode_len), - uid=from_octal(Bin, ?th_uid, ?th_uid_len), - gid=from_octal(Bin, ?th_gid, ?th_gid_len), - size=from_octal(Bin, ?th_size, ?th_size_len), - mtime=from_octal(Bin, ?th_mtime, ?th_mtime_len), - linkname=from_string(Bin, - ?th_linkname, ?th_linkname_len), - typeflag=typeflag(Bin)}, - convert_header1(Hd); - eof -> - eof +parse_octal(Bin) when is_binary(Bin) -> + %% skip leading/trailing zero bytes and spaces + do_parse_octal(Bin, <<>>). +do_parse_octal(<<>>, <<>>) -> + 0; +do_parse_octal(<<>>, Acc) -> + case io_lib:fread("~8u", binary:bin_to_list(Acc)) of + {error, _} -> throw({error, invalid_tar_checksum}); + {ok, [Octal], []} -> Octal; + {ok, _, _} -> throw({error, invalid_tar_checksum}) + end; +do_parse_octal(<<$\s,Rest/binary>>, Acc) -> + do_parse_octal(Rest, Acc); +do_parse_octal(<<0, Rest/binary>>, Acc) -> + do_parse_octal(Rest, Acc); +do_parse_octal(<<C, Rest/binary>>, Acc) -> + do_parse_octal(Rest, <<Acc/binary, C>>). + +parse_string(Bin) when is_binary(Bin) -> + do_parse_string(Bin, <<>>). +do_parse_string(<<>>, Acc) -> + case unicode:characters_to_list(Acc) of + Str when is_list(Str) -> + Str; + {incomplete, _Str, _Rest} -> + binary:bin_to_list(Acc); + {error, _Str, _Rest} -> + throw({error, {bad_header, invalid_string}}) end; -convert_header(Bin) when byte_size(Bin) =:= 0 -> +do_parse_string(<<0, _/binary>>, Acc) -> + do_parse_string(<<>>, Acc); +do_parse_string(<<C, Rest/binary>>, Acc) -> + do_parse_string(Rest, <<Acc/binary, C>>). + +convert_header(Bin, #reader{pos=Pos}=Reader) + when byte_size(Bin) =:= ?BLOCK_SIZE, (Pos rem ?BLOCK_SIZE) =:= 0 -> + case get_format(Bin) of + ?FORMAT_UNKNOWN -> + throw({error, bad_header}); + {ok, Format, V7} -> + unpack_format(Format, V7, Bin, Reader); + {error, Reason} -> + throw({error, {bad_header, Reason}}) + end; +convert_header(Bin, #reader{pos=Pos}) when byte_size(Bin) =:= ?BLOCK_SIZE -> + throw({error, misaligned_read, Pos}); +convert_header(Bin, _Reader) when byte_size(Bin) =:= 0 -> eof; -convert_header(_Bin) -> +convert_header(_Bin, _Reader) -> throw({error, eof}). -%% Basic sanity. Better set the element size to zero here if the type -%% always is of zero length. - -convert_header1(H) when H#tar_header.typeflag =:= symlink, H#tar_header.size =/= 0 -> - convert_header1(H#tar_header{size=0}); -convert_header1(H) when H#tar_header.typeflag =:= directory, H#tar_header.size =/= 0 -> - convert_header1(H#tar_header{size=0}); -convert_header1(Header) -> - Header. - -typeflag(Bin) -> - [T] = binary_to_list(Bin, ?th_typeflag+1, ?th_typeflag+1), - case T of - 0 -> regular; - $0 -> regular; - $1 -> link; - $2 -> symlink; - $3 -> char; - $4 -> block; - $5 -> directory; - $6 -> fifo; - $7 -> regular; - _ -> unknown +%% Creates a partially-populated header record based +%% on the provided file_info record. If the file is +%% a symlink, then `link` is used as the link target. +%% If the file is a directory, a slash is appended to the name. +fileinfo_to_header(Name, #file_info{}=Fi, Link) when is_list(Name) -> + BaseHeader = #tar_header{name=Name, + mtime=Fi#file_info.mtime, + atime=Fi#file_info.atime, + ctime=Fi#file_info.ctime, + mode=Fi#file_info.mode, + uid=Fi#file_info.uid, + gid=Fi#file_info.gid, + typeflag=?TYPE_REGULAR}, + do_fileinfo_to_header(BaseHeader, Fi, Link). + +do_fileinfo_to_header(Header, #file_info{size=Size,type=regular}, _Link) -> + Header#tar_header{size=Size,typeflag=?TYPE_REGULAR}; +do_fileinfo_to_header(#tar_header{name=Name}=Header, + #file_info{type=directory}, _Link) -> + Header#tar_header{name=Name++"/",typeflag=?TYPE_DIR}; +do_fileinfo_to_header(Header, #file_info{type=symlink}, Link) -> + Header#tar_header{typeflag=?TYPE_SYMLINK,linkname=Link}; +do_fileinfo_to_header(Header, #file_info{type=device,mode=Mode}=Fi, _Link) + when (Mode band ?S_IFMT) =:= ?S_IFCHR -> + Header#tar_header{typeflag=?TYPE_CHAR, + devmajor=Fi#file_info.major_device, + devminor=Fi#file_info.minor_device}; +do_fileinfo_to_header(Header, #file_info{type=device,mode=Mode}=Fi, _Link) + when (Mode band ?S_IFMT) =:= ?S_IFBLK -> + Header#tar_header{typeflag=?TYPE_BLOCK, + devmajor=Fi#file_info.major_device, + devminor=Fi#file_info.minor_device}; +do_fileinfo_to_header(Header, #file_info{type=other,mode=Mode}, _Link) + when (Mode band ?S_IFMT) =:= ?S_FIFO -> + Header#tar_header{typeflag=?TYPE_FIFO}; +do_fileinfo_to_header(Header, Fi, _Link) -> + {error, {invalid_file_type, Header#tar_header.name, Fi}}. + +is_ascii(Str) when is_list(Str) -> + not lists:any(fun (Char) -> Char >= 16#80 end, Str); +is_ascii(Bin) when is_binary(Bin) -> + is_ascii1(Bin). + +is_ascii1(<<>>) -> + true; +is_ascii1(<<C,_Rest/binary>>) when C >= 16#80 -> + false; +is_ascii1(<<_, Rest/binary>>) -> + is_ascii1(Rest). + +to_ascii(Str) when is_list(Str) -> + case is_ascii(Str) of + true -> + unicode:characters_to_binary(Str); + false -> + Chars = lists:filter(fun (Char) -> Char < 16#80 end, Str), + unicode:characters_to_binary(Chars) + end; +to_ascii(Bin) when is_binary(Bin) -> + to_ascii(Bin, <<>>). +to_ascii(<<>>, Acc) -> + Acc; +to_ascii(<<C, Rest/binary>>, Acc) when C < 16#80 -> + to_ascii(Rest, <<Acc/binary,C>>); +to_ascii(<<_, Rest/binary>>, Acc) -> + to_ascii(Rest, Acc). + +is_header_only_type(?TYPE_SYMLINK) -> true; +is_header_only_type(?TYPE_LINK) -> true; +is_header_only_type(?TYPE_DIR) -> true; +is_header_only_type(_) -> false. + +foldl_read(#reader{access=read}=Reader, Fun, Accu, #read_opts{}=Opts) + when is_function(Fun,4) -> + case foldl_read0(Reader, Fun, Accu, Opts) of + {ok, Result, _Reader2} -> + Result; + {error, _} = Err -> + Err + end; +foldl_read(#reader{access=Access}, _Fun, _Accu, _Opts) -> + {error, {read_mode_expected, Access}}; +foldl_read(TarName, Fun, Accu, #read_opts{}=Opts) + when is_function(Fun,4) -> + try open(TarName, [read|Opts#read_opts.open_mode]) of + {ok, #reader{access=read}=Reader} -> + try + foldl_read(Reader, Fun, Accu, Opts) + after + _ = close(Reader) + end; + {error, _} = Err -> + Err + catch + throw:Err -> + Err end. -%% Get the name of the file from the prefix and name fields of the -%% tar header. - -get_name(Bin0) -> - List0 = get_name_raw(Bin0), - case file:native_name_encoding() of - utf8 -> - Bin = list_to_binary(List0), - case unicode:characters_to_list(Bin) of - {error,_,_} -> - List0; - List when is_list(List) -> - List - end; - latin1 -> - List0 +foldl_read0(Reader, Fun, Accu, Opts) -> + try foldl_read1(Fun, Accu, Reader, Opts, #{}) of + {ok,_,_} = Ok -> + Ok + catch + throw:{error, {Reason, Format, Args}} -> + read_verbose(Opts, Format, Args), + {error, Reason}; + throw:Err -> + Err end. -get_name_raw(Bin) -> - Name = from_string(Bin, ?th_name, ?th_name_len), - case binary_to_list(Bin, ?th_prefix+1, ?th_prefix+1) of - [0] -> - Name; - [_] -> - Prefix = binary_to_list(Bin, ?th_prefix+1, byte_size(Bin)), - lists:reverse(remove_nulls(Prefix), [$/|Name]) +foldl_read1(Fun, Accu0, Reader0, Opts, ExtraHeaders) -> + {ok, Reader1} = skip_unread(Reader0), + case get_header(Reader1) of + eof -> + Fun(eof, Reader1, Opts, Accu0); + {Header, Reader2} -> + case Header#tar_header.typeflag of + ?TYPE_X_HEADER -> + {ExtraHeaders2, Reader3} = parse_pax(Reader2), + ExtraHeaders3 = maps:merge(ExtraHeaders, ExtraHeaders2), + foldl_read1(Fun, Accu0, Reader3, Opts, ExtraHeaders3); + ?TYPE_GNU_LONGNAME -> + {RealName, Reader3} = get_real_name(Reader2), + ExtraHeaders2 = maps:put(?PAX_PATH, + parse_string(RealName), ExtraHeaders), + foldl_read1(Fun, Accu0, Reader3, Opts, ExtraHeaders2); + ?TYPE_GNU_LONGLINK -> + {RealName, Reader3} = get_real_name(Reader2), + ExtraHeaders2 = maps:put(?PAX_LINKPATH, + parse_string(RealName), ExtraHeaders), + foldl_read1(Fun, Accu0, Reader3, Opts, ExtraHeaders2); + _ -> + Header1 = merge_pax(Header, ExtraHeaders), + {ok, NewAccu, Reader3} = Fun(Header1, Reader2, Opts, Accu0), + foldl_read1(Fun, NewAccu, Reader3, Opts, #{}) + end end. -from_string(Bin, Pos, Len) -> - lists:reverse(remove_nulls(binary_to_list(Bin, Pos+1, Pos+Len))). - -%% Returns all characters up to (but not including) the first null -%% character, in REVERSE order. - -remove_nulls(List) -> - remove_nulls(List, []). - -remove_nulls([0|_], Result) -> - remove_nulls([], Result); -remove_nulls([C|Rest], Result) -> - remove_nulls(Rest, [C|Result]); -remove_nulls([], Result) -> - Result. - -from_octal(Bin, Pos, Len) -> - from_octal(binary_to_list(Bin, Pos+1, Pos+Len)). - -from_octal([$\s|Rest]) -> - from_octal(Rest); -from_octal([Digit|Rest]) when $0 =< Digit, Digit =< $7 -> - from_octal(Rest, Digit-$0); -from_octal(Bin) when is_binary(Bin) -> - from_octal(binary_to_list(Bin)); -from_octal(Other) -> - throw({error, {bad_header, "Bad octal number: ~p", [Other]}}). - -from_octal([Digit|Rest], Result) when $0 =< Digit, Digit =< $7 -> - from_octal(Rest, Result*8+Digit-$0); -from_octal([$\s|_], Result) -> - Result; -from_octal([0|_], Result) -> - Result; -from_octal(Other, _) -> - throw({error, {bad_header, "Bad contents in octal field: ~p", [Other]}}). - -%% Retrieves the next element from the archive. -%% Returns {ok, Bin} | eof | {error, Reason} - -get_element(File, #tar_header{size = 0}) -> - skip_to_next(File), - {ok,<<>>}; -get_element(File, #tar_header{size = Size}) -> - case do_read(File, Size) of - {ok,Bin}=Res when byte_size(Bin) =:= Size -> - skip_to_next(File), - Res; - {ok,List} when length(List) =:= Size -> - skip_to_next(File), - {ok,list_to_binary(List)}; - {ok,_} -> throw({error,eof}); - {error, Reason} -> throw({error, Reason}); - eof -> throw({error,eof}) +%% Applies all known PAX attributes to the current tar header +-spec merge_pax(tar_header(), #{binary() => binary()}) -> tar_header(). +merge_pax(Header, ExtraHeaders) when is_map(ExtraHeaders) -> + do_merge_pax(Header, maps:to_list(ExtraHeaders)). + +do_merge_pax(Header, []) -> + Header; +do_merge_pax(Header, [{?PAX_PATH, Path}|Rest]) -> + do_merge_pax(Header#tar_header{name=unicode:characters_to_list(Path)}, Rest); +do_merge_pax(Header, [{?PAX_LINKPATH, LinkPath}|Rest]) -> + do_merge_pax(Header#tar_header{linkname=unicode:characters_to_list(LinkPath)}, Rest); +do_merge_pax(Header, [{?PAX_GNAME, Gname}|Rest]) -> + do_merge_pax(Header#tar_header{gname=unicode:characters_to_list(Gname)}, Rest); +do_merge_pax(Header, [{?PAX_UNAME, Uname}|Rest]) -> + do_merge_pax(Header#tar_header{uname=unicode:characters_to_list(Uname)}, Rest); +do_merge_pax(Header, [{?PAX_UID, Uid}|Rest]) -> + Uid2 = binary_to_integer(Uid), + do_merge_pax(Header#tar_header{uid=Uid2}, Rest); +do_merge_pax(Header, [{?PAX_GID, Gid}|Rest]) -> + Gid2 = binary_to_integer(Gid), + do_merge_pax(Header#tar_header{gid=Gid2}, Rest); +do_merge_pax(Header, [{?PAX_ATIME, Atime}|Rest]) -> + Atime2 = parse_pax_time(Atime), + do_merge_pax(Header#tar_header{atime=Atime2}, Rest); +do_merge_pax(Header, [{?PAX_MTIME, Mtime}|Rest]) -> + Mtime2 = parse_pax_time(Mtime), + do_merge_pax(Header#tar_header{mtime=Mtime2}, Rest); +do_merge_pax(Header, [{?PAX_CTIME, Ctime}|Rest]) -> + Ctime2 = parse_pax_time(Ctime), + do_merge_pax(Header#tar_header{ctime=Ctime2}, Rest); +do_merge_pax(Header, [{?PAX_SIZE, Size}|Rest]) -> + Size2 = binary_to_integer(Size), + do_merge_pax(Header#tar_header{size=Size2}, Rest); +do_merge_pax(Header, [{<<?PAX_XATTR_STR, _Key/binary>>, _Value}|Rest]) -> + do_merge_pax(Header, Rest); +do_merge_pax(Header, [_Ignore|Rest]) -> + do_merge_pax(Header, Rest). + +%% Returns the time since UNIX epoch as a datetime +-spec parse_pax_time(binary()) -> tar_time(). +parse_pax_time(Bin) when is_binary(Bin) -> + TotalNano = case binary:split(Bin, [<<$.>>]) of + [SecondsStr, NanoStr0] -> + Seconds = binary_to_integer(SecondsStr), + if byte_size(NanoStr0) < ?MAX_NANO_INT_SIZE -> + %% right pad + PaddingN = ?MAX_NANO_INT_SIZE-byte_size(NanoStr0), + Padding = binary:copy(<<$0>>, PaddingN), + NanoStr1 = <<NanoStr0/binary,Padding/binary>>, + Nano = binary_to_integer(NanoStr1), + (Seconds*?BILLION)+Nano; + byte_size(NanoStr0) > ?MAX_NANO_INT_SIZE -> + %% right truncate + NanoStr1 = binary_part(NanoStr0, 0, ?MAX_NANO_INT_SIZE), + Nano = binary_to_integer(NanoStr1), + (Seconds*?BILLION)+Nano; + true -> + (Seconds*?BILLION)+binary_to_integer(NanoStr0) + end; + [SecondsStr] -> + binary_to_integer(SecondsStr)*?BILLION + end, + %% truncate to microseconds + Micro = TotalNano div 1000, + Mega = Micro div 1000000000000, + Secs = Micro div 1000000 - (Mega*1000000), + Secs. + +%% Given a regular file reader, reads the whole file and +%% parses all extended attributes it contains. +parse_pax(#reg_file_reader{handle=Handle,num_bytes=0}) -> + {#{}, Handle}; +parse_pax(#reg_file_reader{handle=Handle0,num_bytes=NumBytes}) -> + case do_read(Handle0, NumBytes) of + {ok, Bytes, Handle1} -> + do_parse_pax(Handle1, Bytes, #{}); + {error, _} = Err -> + throw(Err) end. -%% Verify the checksum in the header. First try an unsigned addition -%% of all bytes in the header (as it should be according to Posix). - -verify_checksum(Bin) -> - <<H1:?th_chksum/binary,CheckStr:?th_chksum_len/binary,H2/binary>> = Bin, - case checksum(H1) + checksum(H2) of - 0 -> eof; - Checksum0 -> - Csum = from_octal(CheckStr), - CsumInit = ?th_chksum_len * $\s, - case Checksum0 + CsumInit of - Csum -> ok; - Unsigned -> - verify_checksum(H1, H2, CsumInit, Csum, Unsigned) - end +do_parse_pax(Reader, <<>>, Headers) -> + {Headers, Reader}; +do_parse_pax(Reader, Bin, Headers) -> + {Key, Value, Residual} = parse_pax_record(Bin), + NewHeaders = maps:put(Key, Value, Headers), + do_parse_pax(Reader, Residual, NewHeaders). + +%% Parse an extended attribute +parse_pax_record(Bin) when is_binary(Bin) -> + case binary:split(Bin, [<<$\n>>]) of + [Record, Residual] -> + case binary:split(Record, [<<$\s>>], [trim_all]) of + [_Len, Record1] -> + case binary:split(Record1, [<<$=>>], [trim_all]) of + [AttrName, AttrValue] -> + {AttrName, AttrValue, Residual}; + _Other -> + throw({error, malformed_pax_record}) + end; + _Other -> + throw({error, malformed_pax_record}) + end; + _Other -> + throw({error, malformed_pax_record}) end. -%% The checksums didn't match. Now try a signed addition. +get_real_name(#reg_file_reader{handle=Handle,num_bytes=0}) -> + {"", Handle}; +get_real_name(#reg_file_reader{handle=Handle0,num_bytes=NumBytes}) -> + case do_read(Handle0, NumBytes) of + {ok, RealName, Handle1} -> + {RealName, Handle1}; + {error, _} = Err -> + throw(Err) + end; +get_real_name(#sparse_file_reader{num_bytes=NumBytes}=Reader0) -> + case do_read(Reader0, NumBytes) of + {ok, RealName, Reader1} -> + {RealName, Reader1}; + {error, _} = Err -> + throw(Err) + end. -verify_checksum(H1, H2, Csum, ShouldBe, Unsigned) -> - case signed_sum(binary_to_list(H1), signed_sum(binary_to_list(H2), Csum)) of - ShouldBe -> ok; - Signed -> - throw({error, - {bad_header, - "Incorrect directory checksum ~w (~w), should be ~w", - [Signed, Unsigned, ShouldBe]}}) +%% Skip the remaining bytes for the current file entry +skip_file(#reg_file_reader{handle=Handle0,pos=Pos,size=Size}=Reader) -> + Padding = skip_padding(Size), + AbsPos = Handle0#reader.pos + (Size-Pos) + Padding, + case do_position(Handle0, AbsPos) of + {ok, _, Handle1} -> + Reader#reg_file_reader{handle=Handle1,num_bytes=0,pos=Size}; + Err -> + throw(Err) + end; +skip_file(#sparse_file_reader{pos=Pos,size=Size}=Reader) -> + case do_read(Reader, Size-Pos) of + {ok, _, Reader2} -> + Reader2; + Err -> + throw(Err) end. -signed_sum([C|Rest], Sum) when C < 128 -> - signed_sum(Rest, Sum+C); -signed_sum([C|Rest], Sum) -> - signed_sum(Rest, Sum+C-256); -signed_sum([], Sum) -> Sum. - -write_extracted_element(Header, Bin, Opts) - when Opts#read_opts.output =:= memory -> - case Header#tar_header.typeflag of - regular -> - {ok, {Header#tar_header.name, Bin}}; - _ -> - ok +skip_padding(0) -> + 0; +skip_padding(Size) when (Size rem ?BLOCK_SIZE) =:= 0 -> + 0; +skip_padding(Size) when Size =< ?BLOCK_SIZE -> + ?BLOCK_SIZE - Size; +skip_padding(Size) -> + ?BLOCK_SIZE - (Size rem ?BLOCK_SIZE). + +skip_unread(#reader{pos=Pos}=Reader0) when (Pos rem ?BLOCK_SIZE) > 0 -> + Padding = skip_padding(Pos + ?BLOCK_SIZE), + AbsPos = Pos + Padding, + case do_position(Reader0, AbsPos) of + {ok, _, Reader1} -> + {ok, Reader1}; + Err -> + throw(Err) + end; +skip_unread(#reader{}=Reader) -> + {ok, Reader}; +skip_unread(#reg_file_reader{handle=Handle,num_bytes=0}) -> + skip_unread(Handle); +skip_unread(#reg_file_reader{}=Reader) -> + #reg_file_reader{handle=Handle} = skip_file(Reader), + {ok, Handle}; +skip_unread(#sparse_file_reader{handle=Handle,num_bytes=0}) -> + skip_unread(Handle); +skip_unread(#sparse_file_reader{}=Reader) -> + #sparse_file_reader{handle=Handle} = skip_file(Reader), + {ok, Handle}. + +write_extracted_element(#tar_header{name=Name,typeflag=Type}, + Bin, + #read_opts{output=memory}=Opts) -> + case typeflag(Type) of + regular -> + read_verbose(Opts, "x ~ts~n", [Name]), + {ok, {Name, Bin}}; + _ -> + ok end; -write_extracted_element(Header, Bin, Opts) -> - Name = filename:absname(Header#tar_header.name, Opts#read_opts.cwd), - Created = - case Header#tar_header.typeflag of - regular -> - write_extracted_file(Name, Bin, Opts); - directory -> - create_extracted_dir(Name, Opts); - symlink -> - create_symlink(Name, Header, Opts); - Other -> % Ignore. - read_verbose(Opts, "x ~ts - unsupported type ~p~n", - [Name, Other]), - not_written - end, +write_extracted_element(#tar_header{name=Name0}=Header, Bin, Opts) -> + Name1 = make_safe_path(Name0, Opts), + Created = + case typeflag(Header#tar_header.typeflag) of + regular -> + create_regular(Name1, Name0, Bin, Opts); + directory -> + read_verbose(Opts, "x ~ts~n", [Name0]), + create_extracted_dir(Name1, Opts); + symlink -> + read_verbose(Opts, "x ~ts~n", [Name0]), + create_symlink(Name1, Header#tar_header.linkname, Opts); + Device when Device =:= char orelse Device =:= block -> + %% char/block devices will be created as empty files + %% and then have their major/minor device set later + create_regular(Name1, Name0, <<>>, Opts); + fifo -> + %% fifo devices will be created as empty files + create_regular(Name1, Name0, <<>>, Opts); + Other -> % Ignore. + read_verbose(Opts, "x ~ts - unsupported type ~p~n", + [Name0, Other]), + not_written + end, case Created of - ok -> set_extracted_file_info(Name, Header); - not_written -> ok + ok -> set_extracted_file_info(Name1, Header); + not_written -> ok + end. + +make_safe_path([$/|Path], Opts) -> + make_safe_path(Path, Opts); +make_safe_path(Path, #read_opts{cwd=Cwd}) -> + case filename:safe_relative_path(Path) of + unsafe -> + throw({error,{Path,unsafe_path}}); + SafePath -> + filename:absname(SafePath, Cwd) + end. + +create_regular(Name, NameInArchive, Bin, Opts) -> + case write_extracted_file(Name, Bin, Opts) of + not_written -> + read_verbose(Opts, "x ~ts - exists, not created~n", [NameInArchive]), + not_written; + Ok -> + read_verbose(Opts, "x ~ts~n", [NameInArchive]), + Ok end. create_extracted_dir(Name, _Opts) -> case file:make_dir(Name) of - ok -> ok; - {error,enotsup} -> not_written; - {error,eexist} -> not_written; - {error,enoent} -> make_dirs(Name, dir); - {error,Reason} -> throw({error, Reason}) + ok -> ok; + {error,enotsup} -> not_written; + {error,eexist} -> not_written; + {error,enoent} -> make_dirs(Name, dir); + {error,Reason} -> throw({error, Reason}) end. -create_symlink(Name, #tar_header{linkname=Linkname}=Header, Opts) -> +create_symlink(Name, Linkname, Opts) -> case file:make_symlink(Linkname, Name) of - ok -> ok; - {error,enoent} -> - ok = make_dirs(Name, file), - create_symlink(Name, Header, Opts); - {error,eexist} -> not_written; - {error,enotsup} -> - read_verbose(Opts, "x ~ts - symbolic links not supported~n", [Name]), - not_written; - {error,Reason} -> throw({error, Reason}) + ok -> ok; + {error,enoent} -> + ok = make_dirs(Name, file), + create_symlink(Name, Linkname, Opts); + {error,eexist} -> not_written; + {error,enotsup} -> + read_verbose(Opts, "x ~ts - symbolic links not supported~n", [Name]), + not_written; + {error,Reason} -> throw({error, Reason}) end. write_extracted_file(Name, Bin, Opts) -> Write = - case Opts#read_opts.keep_old_files of - true -> - case file:read_file_info(Name) of - {ok, _} -> false; - _ -> true - end; - false -> true - end, + case Opts#read_opts.keep_old_files of + true -> + case file:read_file_info(Name) of + {ok, _} -> false; + _ -> true + end; + false -> true + end, case Write of - true -> - read_verbose(Opts, "x ~ts~n", [Name]), - write_file(Name, Bin); - false -> - read_verbose(Opts, "x ~ts - exists, not created~n", [Name]), - not_written + true -> write_file(Name, Bin); + false -> not_written end. write_file(Name, Bin) -> case file:write_file(Name, Bin) of - ok -> ok; - {error,enoent} -> - ok = make_dirs(Name, file), - write_file(Name, Bin); - {error,Reason} -> - throw({error, Reason}) + ok -> ok; + {error,enoent} -> + ok = make_dirs(Name, file), + write_file(Name, Bin); + {error,Reason} -> + throw({error, Reason}) end. -set_extracted_file_info(_, #tar_header{typeflag = symlink}) -> ok; -set_extracted_file_info(Name, #tar_header{mode=Mode, mtime=Mtime}) -> - Info = #file_info{mode=Mode, mtime=posix_to_erlang_time(Mtime)}, +set_extracted_file_info(_, #tar_header{typeflag = ?TYPE_SYMLINK}) -> ok; +set_extracted_file_info(_, #tar_header{typeflag = ?TYPE_LINK}) -> ok; +set_extracted_file_info(Name, #tar_header{typeflag = ?TYPE_CHAR}=Header) -> + set_device_info(Name, Header); +set_extracted_file_info(Name, #tar_header{typeflag = ?TYPE_BLOCK}=Header) -> + set_device_info(Name, Header); +set_extracted_file_info(Name, #tar_header{mtime=Mtime,mode=Mode}) -> + Info = #file_info{mode=Mode, mtime=Mtime}, + file:write_file_info(Name, Info, [{time, posix}]). + +set_device_info(Name, #tar_header{}=Header) -> + Mtime = Header#tar_header.mtime, + Mode = Header#tar_header.mode, + Devmajor = Header#tar_header.devmajor, + Devminor = Header#tar_header.devminor, + Info = #file_info{ + mode=Mode, + mtime=Mtime, + major_device=Devmajor, + minor_device=Devminor + }, file:write_file_info(Name, Info). %% Makes all directories leading up to the file. make_dirs(Name, file) -> - filelib:ensure_dir(Name); + filelib:ensure_dir(Name); make_dirs(Name, dir) -> - filelib:ensure_dir(filename:join(Name,"*")). + filelib:ensure_dir(filename:join(Name,"*")). %% Prints the message on if the verbose option is given (for reading). - read_verbose(#read_opts{verbose=true}, Format, Args) -> - io:format(Format, Args), - io:nl(); + io:format(Format, Args); read_verbose(_, _, _) -> ok. +%% Prints the message on if the verbose option is given. +add_verbose(#add_opts{verbose=true}, Format, Args) -> + io:format(Format, Args); +add_verbose(_, _, _) -> + ok. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%% -%%% Utility functions. -%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -%% Returns the checksum of a binary. - -checksum(Bin) -> checksum(Bin, 0). - -checksum(<<A,B,C,D,E,F,G,H,T/binary>>, Sum) -> - checksum(T, Sum+A+B+C+D+E+F+G+H); -checksum(<<A,T/binary>>, Sum) -> - checksum(T, Sum+A); -checksum(<<>>, Sum) -> Sum. - -%% Returns a list of zeroes to pad out to the given block size. - -padding(Size, BlockSize) -> - zeroes(pad_size(Size, BlockSize)). - -pad_size(Size, BlockSize) -> - case Size rem BlockSize of - 0 -> 0; - Rem -> BlockSize-Rem +%%%%%%%%%%%%%%%%%% +%% I/O primitives +%%%%%%%%%%%%%%%%%% + +do_write(#reader{handle=Handle,func=Fun}=Reader0, Data) + when is_function(Fun,2) -> + case Fun(write,{Handle,Data}) of + ok -> + {ok, Pos, Reader1} = do_position(Reader0, {cur,0}), + {ok, Reader1#reader{pos=Pos}}; + {error, _} = Err -> + Err end. -zeroes(0) -> []; -zeroes(1) -> [0]; -zeroes(2) -> [0,0]; -zeroes(Number) -> - Half = zeroes(Number div 2), - case Number rem 2 of - 0 -> [Half|Half]; - 1 -> [Half|[0|Half]] +do_copy(#reader{func=Fun}=Reader, Source, #add_opts{chunk_size=0}=Opts) + when is_function(Fun, 2) -> + do_copy(Reader, Source, Opts#add_opts{chunk_size=65536}); +do_copy(#reader{func=Fun}=Reader, Source, #add_opts{chunk_size=ChunkSize}) + when is_function(Fun, 2) -> + case file:open(Source, [read, binary]) of + {ok, SourceFd} -> + case copy_chunked(Reader, SourceFd, ChunkSize, 0) of + {ok, _Copied, _Reader2} = Ok-> + _ = file:close(SourceFd), + Ok; + Err -> + _ = file:close(SourceFd), + throw(Err) + end; + Err -> + throw(Err) end. -%% Skips the given number of bytes rounded up to an even record. +copy_chunked(#reader{}=Reader, Source, ChunkSize, Copied) -> + case file:read(Source, ChunkSize) of + {ok, Bin} -> + {ok, Reader2} = do_write(Reader, Bin), + copy_chunked(Reader2, Source, ChunkSize, Copied+byte_size(Bin)); + eof -> + {ok, Copied, Reader}; + Other -> + Other + end. -skip(File, Size) -> - %% Note: There is no point in handling failure to get the current position - %% in the file. If it doesn't work, something serious is wrong. - Amount = ((Size + ?record_size - 1) div ?record_size) * ?record_size, - {ok,_} = do_position(File, {cur, Amount}), - ok. -%% Skips to the next record in the file. +do_position(#reader{handle=Handle,func=Fun}=Reader, Pos) + when is_function(Fun,2)-> + case Fun(position, {Handle,Pos}) of + {ok, NewPos} -> + %% since Pos may not always be an absolute seek, + %% make sure we update the reader with the new absolute position + {ok, AbsPos} = Fun(position, {Handle, {cur, 0}}), + {ok, NewPos, Reader#reader{pos=AbsPos}}; + Other -> + Other + end. -skip_to_next(File) -> - %% Note: There is no point in handling failure to get the current position - %% in the file. If it doesn't work, something serious is wrong. - {ok, Position} = do_position(File, {cur, 0}), - NewPosition = ((Position + ?record_size - 1) div ?record_size) * ?record_size, - {ok,NewPosition} = do_position(File, NewPosition), - ok. +do_read(#reg_file_reader{handle=Handle,pos=Pos,size=Size}=Reader, Len) -> + NumBytes = Size - Pos, + ActualLen = if NumBytes - Len < 0 -> NumBytes; true -> Len end, + case do_read(Handle, ActualLen) of + {ok, Bin, Handle2} -> + NewPos = Pos + ActualLen, + NumBytes2 = Size - NewPos, + Reader1 = Reader#reg_file_reader{ + handle=Handle2, + pos=NewPos, + num_bytes=NumBytes2}, + {ok, Bin, Reader1}; + Other -> + Other + end; +do_read(#sparse_file_reader{}=Reader, Len) -> + do_sparse_read(Reader, Len); +do_read(#reader{pos=Pos,handle=Handle,func=Fun}=Reader, Len) + when is_function(Fun,2)-> + %% Always convert to binary internally + case Fun(read2,{Handle,Len}) of + {ok, List} when is_list(List) -> + Bin = list_to_binary(List), + NewPos = Pos+byte_size(Bin), + {ok, Bin, Reader#reader{pos=NewPos}}; + {ok, Bin} when is_binary(Bin) -> + NewPos = Pos+byte_size(Bin), + {ok, Bin, Reader#reader{pos=NewPos}}; + Other -> + Other + end. -%% Prints the message on if the verbose option is given. -add_verbose(#add_opts{verbose=true}, Format, Args) -> - io:format(Format, Args); -add_verbose(_, _, _) -> - ok. - -%% Converts a tuple containing the time to a Posix time (seconds -%% since Jan 1, 1970). - -posix_time(Time) -> - EpochStart = {{1970,1,1},{0,0,0}}, - {Days,{Hour,Min,Sec}} = calendar:time_difference(EpochStart, Time), - 86400*Days + 3600*Hour + 60*Min + Sec. - -posix_to_erlang_time(Sec) -> - OneMillion = 1000000, - Time = calendar:now_to_datetime({Sec div OneMillion, Sec rem OneMillion, 0}), - erlang:universaltime_to_localtime(Time). - -read_file_and_info(Name, Opts) -> - ReadInfo = Opts#add_opts.read_info, - case ReadInfo(Name) of - {ok,Info} when Info#file_info.type =:= regular, - Opts#add_opts.chunk_size>0 -> - {ok,chunked,Info}; - {ok,Info} when Info#file_info.type =:= regular -> - case file:read_file(Name) of - {ok,Bin} -> - {ok,Bin,Info}; - Error -> - Error - end; - {ok,Info} when Info#file_info.type =:= symlink -> - case file:read_link(Name) of - {ok,PointsTo} -> - {ok,PointsTo,Info}; - Error -> - Error - end; - {ok, Info} -> - {ok,[],Info}; - Error -> - Error +do_sparse_read(Reader, Len) -> + do_sparse_read(Reader, Len, <<>>). + +do_sparse_read(#sparse_file_reader{sparse_map=[#sparse_entry{num_bytes=0}|Entries] + }=Reader0, Len, Acc) -> + %% skip all empty fragments + Reader1 = Reader0#sparse_file_reader{sparse_map=Entries}, + do_sparse_read(Reader1, Len, Acc); +do_sparse_read(#sparse_file_reader{sparse_map=[], + pos=Pos,size=Size}=Reader0, Len, Acc) + when Pos < Size -> + %% if there are no more fragments, it is possible that there is one last sparse hole + %% this behaviour matches the BSD tar utility + %% however, GNU tar stops returning data even if we haven't reached the end + {ok, Bin, Reader1} = read_sparse_hole(Reader0, Size, Len), + do_sparse_read(Reader1, Len-byte_size(Bin), <<Acc/binary,Bin/binary>>); +do_sparse_read(#sparse_file_reader{sparse_map=[]}=Reader, _Len, Acc) -> + {ok, Acc, Reader}; +do_sparse_read(#sparse_file_reader{}=Reader, 0, Acc) -> + {ok, Acc, Reader}; +do_sparse_read(#sparse_file_reader{sparse_map=[#sparse_entry{offset=Offset}|_], + pos=Pos}=Reader0, Len, Acc) + when Pos < Offset -> + {ok, Bin, Reader1} = read_sparse_hole(Reader0, Offset, Offset-Pos), + do_sparse_read(Reader1, Len-byte_size(Bin), <<Acc/binary,Bin/binary>>); +do_sparse_read(#sparse_file_reader{sparse_map=[Entry|Entries], + pos=Pos}=Reader0, Len, Acc) -> + %% we're in a data fragment, so read from it + %% end offset of fragment + EndPos = Entry#sparse_entry.offset + Entry#sparse_entry.num_bytes, + %% bytes left in fragment + NumBytes = EndPos - Pos, + ActualLen = if Len > NumBytes -> NumBytes; true -> Len end, + case do_read(Reader0#sparse_file_reader.handle, ActualLen) of + {ok, Bin, Handle} -> + BytesRead = byte_size(Bin), + ActualEndPos = Pos+BytesRead, + Reader1 = if ActualEndPos =:= EndPos -> + Reader0#sparse_file_reader{sparse_map=Entries}; + true -> + Reader0 + end, + Size = Reader1#sparse_file_reader.size, + NumBytes2 = Size - ActualEndPos, + Reader2 = Reader1#sparse_file_reader{ + handle=Handle, + pos=ActualEndPos, + num_bytes=NumBytes2}, + do_sparse_read(Reader2, Len-byte_size(Bin), <<Acc/binary,Bin/binary>>); + Other -> + Other end. -foreach_while_ok(Fun, [First|Rest]) -> - case Fun(First) of - ok -> foreach_while_ok(Fun, Rest); - Other -> Other - end; -foreach_while_ok(_, []) -> ok. - -open_mode(Mode) -> - open_mode(Mode, false, [raw], []). +%% Reads a sparse hole ending at Offset +read_sparse_hole(#sparse_file_reader{pos=Pos}=Reader, Offset, Len) -> + N = Offset - Pos, + N2 = if N > Len -> + Len; + true -> + N + end, + Bin = <<0:N2/unit:8>>, + NumBytes = Reader#sparse_file_reader.size - (Pos+N2), + {ok, Bin, Reader#sparse_file_reader{ + num_bytes=NumBytes, + pos=Pos+N2}}. + +-spec do_close(reader()) -> ok | {error, term()}. +do_close(#reader{handle=Handle,func=Fun}) when is_function(Fun,2) -> + Fun(close,Handle). + +%%%%%%%%%%%%%%%%%% +%% Option parsing +%%%%%%%%%%%%%%%%%% -open_mode(read, _, Raw, _) -> - {ok, read, Raw, []}; -open_mode(write, _, Raw, _) -> - {ok, write, Raw, []}; -open_mode([read|Rest], false, Raw, Opts) -> - open_mode(Rest, read, Raw, Opts); -open_mode([write|Rest], false, Raw, Opts) -> - open_mode(Rest, write, Raw, Opts); -open_mode([compressed|Rest], Access, Raw, Opts) -> - open_mode(Rest, Access, Raw, [compressed|Opts]); -open_mode([cooked|Rest], Access, _Raw, Opts) -> - open_mode(Rest, Access, [], Opts); -open_mode([], Access, Raw, Opts) -> - {ok, Access, Raw, Opts}; -open_mode(_, _, _, _) -> - {error, einval}. +extract_opts(List) -> + extract_opts(List, default_options()). -%%%================================================================ -do_write({tar_descriptor,UsrHandle,Fun}, Data) -> Fun(write,{UsrHandle,Data}). +table_opts(List) -> + read_opts(List, default_options()). -do_position({tar_descriptor,UsrHandle,Fun}, Pos) -> Fun(position,{UsrHandle,Pos}). +default_options() -> + {ok, Cwd} = file:get_cwd(), + #read_opts{cwd=Cwd}. -do_read({tar_descriptor,UsrHandle,Fun}, Len) -> Fun(read2,{UsrHandle,Len}). +extract_opts([keep_old_files|Rest], Opts) -> + extract_opts(Rest, Opts#read_opts{keep_old_files=true}); +extract_opts([{cwd, Cwd}|Rest], Opts) -> + extract_opts(Rest, Opts#read_opts{cwd=Cwd}); +extract_opts([{files, Files}|Rest], Opts) -> + Set = ordsets:from_list(Files), + extract_opts(Rest, Opts#read_opts{files=Set}); +extract_opts([memory|Rest], Opts) -> + extract_opts(Rest, Opts#read_opts{output=memory}); +extract_opts([compressed|Rest], Opts=#read_opts{open_mode=OpenMode}) -> + extract_opts(Rest, Opts#read_opts{open_mode=[compressed|OpenMode]}); +extract_opts([cooked|Rest], Opts=#read_opts{open_mode=OpenMode}) -> + extract_opts(Rest, Opts#read_opts{open_mode=[cooked|OpenMode]}); +extract_opts([verbose|Rest], Opts) -> + extract_opts(Rest, Opts#read_opts{verbose=true}); +extract_opts([Other|Rest], Opts) -> + extract_opts(Rest, read_opts([Other], Opts)); +extract_opts([], Opts) -> + Opts. -do_close({tar_descriptor,UsrHandle,Fun}) -> Fun(close,UsrHandle). +read_opts([compressed|Rest], Opts=#read_opts{open_mode=OpenMode}) -> + read_opts(Rest, Opts#read_opts{open_mode=[compressed|OpenMode]}); +read_opts([cooked|Rest], Opts=#read_opts{open_mode=OpenMode}) -> + read_opts(Rest, Opts#read_opts{open_mode=[cooked|OpenMode]}); +read_opts([verbose|Rest], Opts) -> + read_opts(Rest, Opts#read_opts{verbose=true}); +read_opts([_|Rest], Opts) -> + read_opts(Rest, Opts); +read_opts([], Opts) -> + Opts. diff --git a/lib/stdlib/src/erl_tar.hrl b/lib/stdlib/src/erl_tar.hrl new file mode 100644 index 0000000000..cff0c2f500 --- /dev/null +++ b/lib/stdlib/src/erl_tar.hrl @@ -0,0 +1,396 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2017. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% + +%% Options used when adding files to a tar archive. +-record(add_opts, { + read_info, %% Fun to use for read file/link info. + chunk_size = 0, %% For file reading when sending to sftp. 0=do not chunk + verbose = false}). %% Verbose on/off. +-type add_opts() :: #add_opts{}. + +%% Options used when reading a tar archive. +-record(read_opts, { + cwd :: string(), %% Current working directory. + keep_old_files = false :: boolean(), %% Owerwrite or not. + files = all, %% Set of files to extract (or all) + output = file :: 'file' | 'memory', + open_mode = [], %% Open mode options. + verbose = false :: boolean()}). %% Verbose on/off. +-type read_opts() :: #read_opts{}. + +-type add_opt() :: dereference | + verbose | + {chunks, pos_integer()}. + +-type extract_opt() :: {cwd, string()} | + {files, [string()]} | + compressed | + cooked | + memory | + keep_old_files | + verbose. + +-type create_opt() :: compressed | + cooked | + dereference | + verbose. + +-type filelist() :: [file:filename() | + {string(), binary()} | + {string(), file:filename()}]. + +-type tar_time() :: non_neg_integer(). + +%% The tar header, once fully parsed. +-record(tar_header, { + name = "" :: string(), %% name of header file entry + mode = 8#100644 :: non_neg_integer(), %% permission and mode bits + uid = 0 :: non_neg_integer(), %% user id of owner + gid = 0 :: non_neg_integer(), %% group id of owner + size = 0 :: non_neg_integer(), %% length in bytes + mtime :: tar_time(), %% modified time + typeflag :: char(), %% type of header entry + linkname = "" :: string(), %% target name of link + uname = "" :: string(), %% user name of owner + gname = "" :: string(), %% group name of owner + devmajor = 0 :: non_neg_integer(), %% major number of character or block device + devminor = 0 :: non_neg_integer(), %% minor number of character or block device + atime :: tar_time(), %% access time + ctime :: tar_time() %% status change time + }). +-type tar_header() :: #tar_header{}. + +%% Metadata for a sparse file fragment +-record(sparse_entry, { + offset = 0 :: non_neg_integer(), + num_bytes = 0 :: non_neg_integer()}). +-type sparse_entry() :: #sparse_entry{}. +%% Contains metadata about fragments of a sparse file +-record(sparse_array, { + entries = [] :: [sparse_entry()], + is_extended = false :: boolean(), + max_entries = 0 :: non_neg_integer()}). +-type sparse_array() :: #sparse_array{}. +%% A subset of tar header fields common to all tar implementations +-record(header_v7, { + name :: binary(), + mode :: binary(), %% octal + uid :: binary(), %% integer + gid :: binary(), %% integer + size :: binary(), %% integer + mtime :: binary(), %% integer + checksum :: binary(), %% integer + typeflag :: byte(), %% char + linkname :: binary()}). +-type header_v7() :: #header_v7{}. +%% The set of fields specific to GNU tar formatted archives +-record(header_gnu, { + header_v7 :: header_v7(), + magic :: binary(), + version :: binary(), + uname :: binary(), + gname :: binary(), + devmajor :: binary(), %% integer + devminor :: binary(), %% integer + atime :: binary(), %% integer + ctime :: binary(), %% integer + sparse :: sparse_array(), + real_size :: binary()}). %% integer +-type header_gnu() :: #header_gnu{}. +%% The set of fields specific to STAR-formatted archives +-record(header_star, { + header_v7 :: header_v7(), + magic :: binary(), + version :: binary(), + uname :: binary(), + gname :: binary(), + devmajor :: binary(), %% integer + devminor :: binary(), %% integer + prefix :: binary(), + atime :: binary(), %% integer + ctime :: binary(), %% integer + trailer :: binary()}). +-type header_star() :: #header_star{}. +%% The set of fields specific to USTAR-formatted archives +-record(header_ustar, { + header_v7 :: header_v7(), + magic :: binary(), + version :: binary(), + uname :: binary(), + gname :: binary(), + devmajor :: binary(), %% integer + devminor :: binary(), %% integer + prefix :: binary()}). +-type header_ustar() :: #header_ustar{}. + +-type header_fields() :: header_v7() | + header_gnu() | + header_star() | + header_ustar(). + +%% The overall tar reader, it holds the low-level file handle, +%% its access, position, and the I/O primitives wrapper. +-record(reader, { + handle :: file:io_device() | term(), + access :: read | write | ram, + pos = 0 :: non_neg_integer(), + func :: file_op() + }). +-type reader() :: #reader{}. +%% A reader for a regular file within the tar archive, +%% It tracks its current state relative to that file. +-record(reg_file_reader, { + handle :: reader(), + num_bytes = 0, + pos = 0, + size = 0 + }). +-type reg_file_reader() :: #reg_file_reader{}. +%% A reader for a sparse file within the tar archive, +%% It tracks its current state relative to that file. +-record(sparse_file_reader, { + handle :: reader(), + num_bytes = 0, %% bytes remaining + pos = 0, %% pos + size = 0, %% total size of file + sparse_map = #sparse_array{} + }). +-type sparse_file_reader() :: #sparse_file_reader{}. + +%% Types for the readers +-type reader_type() :: reader() | reg_file_reader() | sparse_file_reader(). +-type handle() :: file:io_device() | term(). + +%% Type for the I/O primitive wrapper function +-type file_op() :: fun((write | close | read2 | position, + {handle(), iodata()} | handle() | {handle(), non_neg_integer()} + | {handle(), non_neg_integer()}) -> + ok | eof | {ok, string() | binary()} | {ok, non_neg_integer()} + | {error, term()}). + +%% These constants (except S_IFMT) are +%% used to determine what type of device +%% a file is. Namely, `S_IFMT band file_info.mode` +%% will equal one of these contants, and tells us +%% which type it is. The stdlib file_info record +%% does not differentiate between device types, and +%% will not allow us to differentiate between sockets +%% and named pipes. These constants are pulled from libc. +-define(S_IFMT, 61440). +-define(S_IFSOCK, 49152). %% socket +-define(S_FIFO, 4096). %% fifo/named pipe +-define(S_IFBLK, 24576). %% block device +-define(S_IFCHR, 8192). %% character device + +%% Typeflag constants for the tar header +-define(TYPE_REGULAR, $0). %% regular file +-define(TYPE_REGULAR_A, 0). %% regular file +-define(TYPE_LINK, $1). %% hard link +-define(TYPE_SYMLINK, $2). %% symbolic link +-define(TYPE_CHAR, $3). %% character device node +-define(TYPE_BLOCK, $4). %% block device node +-define(TYPE_DIR, $5). %% directory +-define(TYPE_FIFO, $6). %% fifo node +-define(TYPE_CONT, $7). %% reserved +-define(TYPE_X_HEADER, $x). %% extended header +-define(TYPE_X_GLOBAL_HEADER, $g). %% global extended header +-define(TYPE_GNU_LONGNAME, $L). %% next file has a long name +-define(TYPE_GNU_LONGLINK, $K). %% next file symlinks to a file with a long name +-define(TYPE_GNU_SPARSE, $S). %% sparse file + +%% Mode constants from tar spec +-define(MODE_ISUID, 4000). %% set uid +-define(MODE_ISGID, 2000). %% set gid +-define(MODE_ISVTX, 1000). %% save text (sticky bit) +-define(MODE_ISDIR, 40000). %% directory +-define(MODE_ISFIFO, 10000). %% fifo +-define(MODE_ISREG, 100000). %% regular file +-define(MODE_ISLNK, 120000). %% symbolic link +-define(MODE_ISBLK, 60000). %% block special file +-define(MODE_ISCHR, 20000). %% character special file +-define(MODE_ISSOCK, 140000). %% socket + +%% Keywords for PAX extended header +-define(PAX_ATIME, <<"atime">>). +-define(PAX_CHARSET, <<"charset">>). +-define(PAX_COMMENT, <<"comment">>). +-define(PAX_CTIME, <<"ctime">>). %% ctime is not a valid pax header +-define(PAX_GID, <<"gid">>). +-define(PAX_GNAME, <<"gname">>). +-define(PAX_LINKPATH, <<"linkpath">>). +-define(PAX_MTIME, <<"mtime">>). +-define(PAX_PATH, <<"path">>). +-define(PAX_SIZE, <<"size">>). +-define(PAX_UID, <<"uid">>). +-define(PAX_UNAME, <<"uname">>). +-define(PAX_XATTR, <<"SCHILY.xattr.">>). +-define(PAX_XATTR_STR, "SCHILY.xattr."). +-define(PAX_NONE, <<"">>). + +%% Tar format constants +%% Unknown format +-define(FORMAT_UNKNOWN, 0). +%% The format of the original Unix V7 tar tool prior to standardization +-define(FORMAT_V7, 1). +%% The old and new GNU formats, incompatible with USTAR. +%% This covers the old GNU sparse extension, but it does +%% not cover the GNU sparse extensions using PAX headers, +%% versions 0.0, 0.1, and 1.0; these fall under the PAX format. +-define(FORMAT_GNU, 2). +%% Schily's tar format, which is incompatible with USTAR. +%% This does not cover STAR extensions to the PAX format; these +%% fall under the PAX format. +-define(FORMAT_STAR, 3). +%% USTAR is the former standardization of tar defined in POSIX.1-1988, +%% it is incompatible with the GNU and STAR formats. +-define(FORMAT_USTAR, 4). +%% PAX is the latest standardization of tar defined in POSIX.1-2001. +%% This is an extension of USTAR and is "backwards compatible" with it. +%% +%% Some newer formats add their own extensions to PAX, such as GNU sparse +%% files and SCHILY extended attributes. Since they are backwards compatible +%% with PAX, they will be labelled as "PAX". +-define(FORMAT_PAX, 5). + +%% Magic constants +-define(MAGIC_GNU, <<"ustar ">>). +-define(VERSION_GNU, <<" \x00">>). +-define(MAGIC_USTAR, <<"ustar\x00">>). +-define(VERSION_USTAR, <<"00">>). +-define(TRAILER_STAR, <<"tar\x00">>). + +%% Size constants +-define(BLOCK_SIZE, 512). %% size of each block in a tar stream +-define(NAME_SIZE, 100). %% max length of the name field in USTAR format +-define(PREFIX_SIZE, 155). %% max length of the prefix field in USTAR format + +%% Maximum size of a nanosecond value as an integer +-define(MAX_NANO_INT_SIZE, 9). +%% Maximum size of a 64-bit signed integer +-define(MAX_INT64, (1 bsl 63 - 1)). + +-define(PAX_GNU_SPARSE_NUMBLOCKS, <<"GNU.sparse.numblocks">>). +-define(PAX_GNU_SPARSE_OFFSET, <<"GNU.sparse.offset">>). +-define(PAX_GNU_SPARSE_NUMBYTES, <<"GNU.sparse.numbytes">>). +-define(PAX_GNU_SPARSE_MAP, <<"GNU.sparse.map">>). +-define(PAX_GNU_SPARSE_NAME, <<"GNU.sparse.name">>). +-define(PAX_GNU_SPARSE_MAJOR, <<"GNU.sparse.major">>). +-define(PAX_GNU_SPARSE_MINOR, <<"GNU.sparse.minor">>). +-define(PAX_GNU_SPARSE_SIZE, <<"GNU.sparse.size">>). +-define(PAX_GNU_SPARSE_REALSIZE, <<"GNU.sparse.realsize">>). + +-define(V7_NAME, 0). +-define(V7_NAME_LEN, 100). +-define(V7_MODE, 100). +-define(V7_MODE_LEN, 8). +-define(V7_UID, 108). +-define(V7_UID_LEN, 8). +-define(V7_GID, 116). +-define(V7_GID_LEN, 8). +-define(V7_SIZE, 124). +-define(V7_SIZE_LEN, 12). +-define(V7_MTIME, 136). +-define(V7_MTIME_LEN, 12). +-define(V7_CHKSUM, 148). +-define(V7_CHKSUM_LEN, 8). +-define(V7_TYPE, 156). +-define(V7_TYPE_LEN, 1). +-define(V7_LINKNAME, 157). +-define(V7_LINKNAME_LEN, 100). + +-define(STAR_TRAILER, 508). +-define(STAR_TRAILER_LEN, 4). + +-define(USTAR_MAGIC, 257). +-define(USTAR_MAGIC_LEN, 6). +-define(USTAR_VERSION, 263). +-define(USTAR_VERSION_LEN, 2). +-define(USTAR_UNAME, 265). +-define(USTAR_UNAME_LEN, 32). +-define(USTAR_GNAME, 297). +-define(USTAR_GNAME_LEN, 32). +-define(USTAR_DEVMAJ, 329). +-define(USTAR_DEVMAJ_LEN, 8). +-define(USTAR_DEVMIN, 337). +-define(USTAR_DEVMIN_LEN, 8). +-define(USTAR_PREFIX, 345). +-define(USTAR_PREFIX_LEN, 155). + +-define(GNU_MAGIC, 257). +-define(GNU_MAGIC_LEN, 6). +-define(GNU_VERSION, 263). +-define(GNU_VERSION_LEN, 2). + +%% ?BLOCK_SIZE of zero-bytes. +%% Two of these in a row mark the end of an archive. +-define(ZERO_BLOCK, <<0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0>>). + +-define(BILLION, 1000000000). + +-define(EPOCH, {{1970,1,1}, {0,0,0}}). diff --git a/lib/stdlib/src/error_logger_file_h.erl b/lib/stdlib/src/error_logger_file_h.erl index a7f3615972..58da0cbdd6 100644 --- a/lib/stdlib/src/error_logger_file_h.erl +++ b/lib/stdlib/src/error_logger_file_h.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2012. All Rights Reserved. +%% Copyright Ericsson AB 1996-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -24,24 +24,28 @@ %%% %%% A handler that can be connected to the error_logger -%%% event handler. -%%% Writes all events formatted to file. -%%% Handles events tagged error, emulator and info. +%%% event handler. Writes all events formatted to file. %%% %%% It can only be started from error_logger:swap_handler({logfile, File}) -%%% or error_logger:logfile(File) +%%% or error_logger:logfile(File). %%% -export([init/1, handle_event/2, handle_call/2, handle_info/2, terminate/2, code_change/3]). +-record(st, + {fd, + filename, + prev_handler, + depth=unlimited :: 'unlimited' | non_neg_integer()}). + %% This one is used when we takeover from the simple error_logger. init({File, {error_logger, Buf}}) -> case init(File, error_logger) of - {ok, {Fd, File, PrevHandler}} -> - write_events(Fd, Buf), - {ok, {Fd, File, PrevHandler}}; + {ok, State} -> + write_events(State, Buf), + {ok, State}; Error -> Error end; @@ -51,51 +55,39 @@ init(File) -> init(File, PrevHandler) -> process_flag(trap_exit, true), - case file:open(File, [write]) of + case file:open(File, [write,{encoding,utf8}]) of {ok,Fd} -> - {ok, {Fd, File, PrevHandler}}; + Depth = error_logger:get_format_depth(), + State = #st{fd=Fd,filename=File,prev_handler=PrevHandler, + depth=Depth}, + {ok, State}; Error -> Error end. - + handle_event({_Type, GL, _Msg}, State) when node(GL) =/= node() -> {ok, State}; -handle_event(Event, {Fd, File, PrevHandler}) -> - write_event(Fd, tag_event(Event)), - {ok, {Fd, File, PrevHandler}}; -handle_event(_, State) -> +handle_event(Event, State) -> + write_event(State, Event), {ok, State}. -handle_info({'EXIT', Fd, _Reason}, {Fd, _File, PrevHandler}) -> +handle_info({'EXIT', Fd, _Reason}, #st{fd=Fd,prev_handler=PrevHandler}) -> case PrevHandler of [] -> remove_handler; _ -> {swap_handler, install_prev, [], PrevHandler, go_back} end; -handle_info({emulator, GL, Chars}, {Fd, File, PrevHandler}) - when node(GL) == node() -> - write_event(Fd, tag_event({emulator, GL, Chars})), - {ok, {Fd, File, PrevHandler}}; -handle_info({emulator, noproc, Chars}, {Fd, File, PrevHandler}) -> - write_event(Fd, tag_event({emulator, noproc, Chars})), - {ok, {Fd, File, PrevHandler}}; handle_info(_, State) -> {ok, State}. -handle_call(filename, {Fd, File, Prev}) -> - {ok, File, {Fd, File, Prev}}; +handle_call(filename, #st{filename=File}=State) -> + {ok, File, State}; handle_call(_Query, State) -> {ok, {error, bad_query}, State}. -terminate(_Reason, State) -> - case State of - {Fd, _File, _Prev} -> - ok = file:close(Fd); - _ -> - ok - end, - []. +terminate(_Reason, #st{fd=Fd}) -> + file:close(Fd). code_change(_OldVsn, State, _Extra) -> {ok, State}. @@ -104,144 +96,123 @@ code_change(_OldVsn, State, _Extra) -> %%% Misc. functions. %%% ------------------------------------------------------ -tag_event(Event) -> - {erlang:universaltime(), Event}. - -write_events(Fd, Events) -> write_events1(Fd, lists:reverse(Events)). - -write_events1(Fd, [Event|Es]) -> - write_event(Fd, Event), - write_events1(Fd, Es); -write_events1(_, []) -> +write_events(State, [Ev|Es]) -> + %% Write the events in reversed order. + write_events(State, Es), + write_event(State, Ev); +write_events(_State, []) -> ok. -write_event(Fd, {Time, {error, _GL, {Pid, Format, Args}}}) -> - T = write_time(maybe_utc(Time)), - case catch io_lib:format(add_node(Format,Pid), Args) of - S when is_list(S) -> - io:format(Fd, T ++ S, []); - _ -> - F = add_node("ERROR: ~p - ~p~n", Pid), - io:format(Fd, T ++ F, [Format,Args]) - end; -write_event(Fd, {Time, {emulator, _GL, Chars}}) -> - T = write_time(maybe_utc(Time)), - case catch io_lib:format(Chars, []) of - S when is_list(S) -> - io:format(Fd, T ++ S, []); - _ -> - io:format(Fd, T ++ "ERROR: ~p ~n", [Chars]) - end; -write_event(Fd, {Time, {info, _GL, {Pid, Info, _}}}) -> - T = write_time(maybe_utc(Time)), - io:format(Fd, T ++ add_node("~p~n",Pid),[Info]); -write_event(Fd, {Time, {error_report, _GL, {Pid, std_error, Rep}}}) -> - T = write_time(maybe_utc(Time)), - S = format_report(Rep), - io:format(Fd, T ++ S ++ add_node("", Pid), []); -write_event(Fd, {Time, {info_report, _GL, {Pid, std_info, Rep}}}) -> - T = write_time(maybe_utc(Time), "INFO REPORT"), - S = format_report(Rep), - io:format(Fd, T ++ S ++ add_node("", Pid), []); -write_event(Fd, {Time, {info_msg, _GL, {Pid, Format, Args}}}) -> - T = write_time(maybe_utc(Time), "INFO REPORT"), - case catch io_lib:format(add_node(Format,Pid), Args) of - S when is_list(S) -> - io:format(Fd, T ++ S, []); - _ -> - F = add_node("ERROR: ~p - ~p~n", Pid), - io:format(Fd, T ++ F, [Format,Args]) - end; -write_event(Fd, {Time, {warning_report, _GL, {Pid, std_warning, Rep}}}) -> - T = write_time(maybe_utc(Time), "WARNING REPORT"), - S = format_report(Rep), - io:format(Fd, T ++ S ++ add_node("", Pid), []); -write_event(Fd, {Time, {warning_msg, _GL, {Pid, Format, Args}}}) -> - T = write_time(maybe_utc(Time), "WARNING REPORT"), - case catch io_lib:format(add_node(Format,Pid), Args) of - S when is_list(S) -> - io:format(Fd, T ++ S, []); - _ -> - F = add_node("ERROR: ~p - ~p~n", Pid), - io:format(Fd, T ++ F, [Format,Args]) - end; -write_event(_, _) -> - ok. +write_event(#st{fd=Fd}=State, Event) -> + case parse_event(Event) of + ignore -> + ok; + {Head,Pid,FormatList} -> + Time = erlang:universaltime(), + Header = header(Time, Head), + Body = format_body(State, FormatList), + AtNode = if + node(Pid) =/= node() -> + ["** at node ",atom_to_list(node(Pid))," **\n"]; + true -> + [] + end, + io:put_chars(Fd, [Header,AtNode,Body]) + end. -maybe_utc(Time) -> - UTC = case application:get_env(sasl, utc_log) of - {ok, Val} -> Val; - undefined -> - %% Backwards compatible: - case application:get_env(stdlib, utc_log) of - {ok, Val} -> Val; - undefined -> false - end - end, - maybe_utc(Time, UTC). +format_body(State, [{Format,Args}|T]) -> + S = try format(State, Format, Args) of + S0 -> + S0 + catch + _:_ -> + format(State, "ERROR: ~tp - ~tp\n", [Format,Args]) + end, + [S|format_body(State, T)]; +format_body(_State, []) -> + []. -maybe_utc(Time, true) -> {utc, Time}; -maybe_utc(Time, _) -> {local, calendar:universal_time_to_local_time(Time)}. +format(#st{depth=unlimited}, Format, Args) -> + io_lib:format(Format, Args); +format(#st{depth=Depth}, Format0, Args) -> + Format1 = io_lib:scan_format(Format0, Args), + Format = limit_format(Format1, Depth), + io_lib:build_text(Format). + +limit_format([#{control_char:=C0}=M0|T], Depth) when C0 =:= $p; + C0 =:= $w -> + C = C0 - ($a - $A), %To uppercase. + #{args:=Args} = M0, + M = M0#{control_char:=C,args:=Args++[Depth]}, + [M|limit_format(T, Depth)]; +limit_format([H|T], Depth) -> + [H|limit_format(T, Depth)]; +limit_format([], _) -> + []. -format_report(Rep) when is_list(Rep) -> - case string_p(Rep) of +parse_event({error, _GL, {Pid, Format, Args}}) -> + {"ERROR REPORT",Pid,[{Format,Args}]}; +parse_event({info_msg, _GL, {Pid, Format, Args}}) -> + {"INFO REPORT",Pid,[{Format, Args}]}; +parse_event({warning_msg, _GL, {Pid, Format, Args}}) -> + {"WARNING REPORT",Pid,[{Format,Args}]}; +parse_event({error_report, _GL, {Pid, std_error, Args}}) -> + {"ERROR REPORT",Pid,format_term(Args)}; +parse_event({info_report, _GL, {Pid, std_info, Args}}) -> + {"INFO REPORT",Pid,format_term(Args)}; +parse_event({warning_report, _GL, {Pid, std_warning, Args}}) -> + {"WARNING REPORT",Pid,format_term(Args)}; +parse_event(_) -> ignore. + +format_term(Term) when is_list(Term) -> + case string_p(lists:flatten(Term)) of true -> - io_lib:format("~s~n",[Rep]); - _ -> - format_rep(Rep) + [{"~ts\n",[Term]}]; + false -> + format_term_list(Term) end; -format_report(Rep) -> - io_lib:format("~p~n",[Rep]). - -format_rep([{Tag,Data}|Rep]) -> - io_lib:format(" ~p: ~p~n",[Tag,Data]) ++ format_rep(Rep); -format_rep([Other|Rep]) -> - io_lib:format(" ~p~n",[Other]) ++ format_rep(Rep); -format_rep(_) -> +format_term(Term) -> + [{"~tp\n",[Term]}]. + +format_term_list([{Tag,Data}|T]) -> + [{" ~tp: ~tp\n",[Tag,Data]}|format_term_list(T)]; +format_term_list([Data|T]) -> + [{" ~tp\n",[Data]}|format_term_list(T)]; +format_term_list([]) -> []. -add_node(X, Pid) when is_atom(X) -> - add_node(atom_to_list(X), Pid); -add_node(X, Pid) when node(Pid) =/= node() -> - lists:concat([X,"** at node ",node(Pid)," **~n"]); -add_node(X, _) -> - X. - string_p([]) -> false; -string_p(Term) -> - string_p1(Term). - -string_p1([H|T]) when is_integer(H), H >= $\s, H < 255 -> - string_p1(T); -string_p1([$\n|T]) -> string_p1(T); -string_p1([$\r|T]) -> string_p1(T); -string_p1([$\t|T]) -> string_p1(T); -string_p1([$\v|T]) -> string_p1(T); -string_p1([$\b|T]) -> string_p1(T); -string_p1([$\f|T]) -> string_p1(T); -string_p1([$\e|T]) -> string_p1(T); -string_p1([H|T]) when is_list(H) -> - case string_p1(H) of - true -> string_p1(T); - _ -> false - end; -string_p1([]) -> true; -string_p1(_) -> false. +string_p(FlatList) -> + io_lib:printable_list(FlatList). + +get_utc_config() -> + %% SASL utc_log configuration overrides stdlib config + %% in order to have uniform timestamps in log messages + case application:get_env(sasl, utc_log) of + {ok, Val} -> Val; + undefined -> + case application:get_env(stdlib, utc_log) of + {ok, Val} -> Val; + undefined -> false + end + end. -write_time(Time) -> write_time(Time, "ERROR REPORT"). +header(Time, Title) -> + case get_utc_config() of + true -> + header(Time, Title, "UTC "); + _ -> + header(calendar:universal_time_to_local_time(Time), Title, "") + end. -write_time({utc,{{Y,Mo,D},{H,Mi,S}}}, Type) -> - io_lib:format("~n=~s==== ~p-~s-~p::~s:~s:~s UTC ===~n", - [Type,D,month(Mo),Y,t(H),t(Mi),t(S)]); -write_time({local, {{Y,Mo,D},{H,Mi,S}}}, Type) -> - io_lib:format("~n=~s==== ~p-~s-~p::~s:~s:~s ===~n", - [Type,D,month(Mo),Y,t(H),t(Mi),t(S)]). +header({{Y,Mo,D},{H,Mi,S}}, Title, UTC) -> + io_lib:format("~n=~ts==== ~p-~s-~p::~s:~s:~s ~s===~n", + [Title,D,month(Mo),Y,t(H),t(Mi),t(S),UTC]). t(X) when is_integer(X) -> - t1(integer_to_list(X)); -t(_) -> - "". + t1(integer_to_list(X)). + t1([X]) -> [$0,X]; t1(X) -> X. @@ -257,5 +228,3 @@ month(9) -> "Sep"; month(10) -> "Oct"; month(11) -> "Nov"; month(12) -> "Dec". - - diff --git a/lib/stdlib/src/error_logger_tty_h.erl b/lib/stdlib/src/error_logger_tty_h.erl index 65ea645bd9..fa940b7264 100644 --- a/lib/stdlib/src/error_logger_tty_h.erl +++ b/lib/stdlib/src/error_logger_tty_h.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2013. All Rights Reserved. +%% Copyright Ericsson AB 1996-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -23,217 +23,221 @@ %%% %%% A handler that can be connected to the error_logger -%%% event handler. -%%% Writes all events formatted to stdout. -%%% Handles events tagged error, emulator and info. +%%% event handler. Writes all events formatted to stdout. %%% %%% It can only be started from error_logger:swap_handler(tty) -%%% or error_logger:tty(true) +%%% or error_logger:tty(true). %%% -export([init/1, handle_event/2, handle_call/2, handle_info/2, terminate/2, code_change/3]). --export([write_event/2]). +-export([write_event/2,write_event/3]). + +-record(st, + {user, + prev_handler, + io_mod=io, + depth=unlimited, + modifier=""}). %% This one is used when we takeover from the simple error_logger. init({[], {error_logger, Buf}}) -> User = set_group_leader(), - write_events(Buf,io), - {ok, {User, error_logger}}; + Depth = error_logger:get_format_depth(), + Modifier = modifier(), + State = #st{user=User,prev_handler=error_logger, + depth=Depth,modifier=Modifier}, + write_events(State, Buf), + {ok, State}; %% This one is used if someone took over from us, and now wants to %% go back. init({[], {error_logger_tty_h, PrevHandler}}) -> User = set_group_leader(), - {ok, {User, PrevHandler}}; + {ok, #st{user=User,prev_handler=PrevHandler}}; %% This one is used when we are started directly. init([]) -> User = set_group_leader(), - {ok, {User, []}}. - + Depth = error_logger:get_format_depth(), + Modifier = modifier(), + {ok, #st{user=User,prev_handler=[],depth=Depth,modifier=Modifier}}. + handle_event({_Type, GL, _Msg}, State) when node(GL) =/= node() -> {ok, State}; handle_event(Event, State) -> - ok = write_event(tag_event(Event),io), + ok = do_write_event(State, tag_event(Event)), {ok, State}. -handle_info({'EXIT', User, _Reason}, {User, PrevHandler}) -> +handle_info({'EXIT', User, _Reason}, + #st{user=User,prev_handler=PrevHandler}=State) -> case PrevHandler of [] -> remove_handler; _ -> - {swap_handler, install_prev, {User, PrevHandler}, + {swap_handler, install_prev, State, PrevHandler, go_back} end; -handle_info({emulator, GL, Chars}, State) when node(GL) == node() -> - ok = write_event(tag_event({emulator, GL, Chars}),io), - {ok, State}; -handle_info({emulator, noproc, Chars}, State) -> - ok = write_event(tag_event({emulator, noproc, Chars}),io), - {ok, State}; handle_info(_, State) -> {ok, State}. handle_call(_Query, State) -> {ok, {error, bad_query}, State}. -% unfortunately, we can't unlink from User - links are not counted! -% if pid(User) -> unlink(User); true -> ok end, terminate(install_prev, _State) -> []; -terminate(_Reason, {_User, PrevHandler}) -> +terminate(_Reason, #st{prev_handler=PrevHandler}) -> {error_logger_tty_h, PrevHandler}. code_change(_OldVsn, State, _Extra) -> {ok, State}. +%% Exported (but unoffical) API. +write_event(Event, IoMod) -> + do_write_event(#st{io_mod=IoMod}, Event). + +write_event(Event, IoMod, {Depth, Enc}) -> + Modifier = modifier(Enc), + do_write_event(#st{io_mod=IoMod,depth=Depth,modifier=Modifier}, Event). + + %%% ------------------------------------------------------ %%% Misc. functions. %%% ------------------------------------------------------ set_group_leader() -> case whereis(user) of - User when is_pid(User) -> link(User), group_leader(User,self()), User; - _ -> false + User when is_pid(User) -> + link(User), + group_leader(User,self()), + User; + _ -> + false end. tag_event(Event) -> {erlang:universaltime(), Event}. -%% IOMOd is always 'io' -write_events(Events,IOMod) -> write_events1(lists:reverse(Events),IOMod). - -write_events1([Event|Es],IOMod) -> - ok = write_event(Event,IOMod), - write_events1(Es,IOMod); -write_events1([],_IOMod) -> +write_events(State, [Ev|Es]) -> + %% Write the events in reverse order. + _ = write_events(State, Es), + _ = do_write_event(State, Ev), + ok; +write_events(_State, []) -> ok. -write_event({Time, {error, _GL, {Pid, Format, Args}}},IOMod) -> - T = write_time(maybe_utc(Time)), - case catch io_lib:format(add_node(Format,Pid), Args) of - S when is_list(S) -> - format(IOMod, T ++ S); - _ -> - F = add_node("ERROR: ~p - ~p~n", Pid), - format(IOMod, T ++ F, [Format,Args]) - end; -write_event({Time, {emulator, _GL, Chars}},IOMod) -> - T = write_time(maybe_utc(Time)), - case catch io_lib:format(Chars, []) of - S when is_list(S) -> - format(IOMod, T ++ S); - _ -> - format(IOMod, T ++ "ERROR: ~p ~n", [Chars]) - end; -write_event({Time, {info, _GL, {Pid, Info, _}}},IOMod) -> - T = write_time(maybe_utc(Time)), - format(IOMod, T ++ add_node("~p~n",Pid),[Info]); -write_event({Time, {error_report, _GL, {Pid, std_error, Rep}}},IOMod) -> - T = write_time(maybe_utc(Time)), - S = format_report(Rep), - format(IOMod, T ++ S ++ add_node("", Pid)); -write_event({Time, {info_report, _GL, {Pid, std_info, Rep}}},IOMod) -> - T = write_time(maybe_utc(Time), "INFO REPORT"), - S = format_report(Rep), - format(IOMod, T ++ S ++ add_node("", Pid)); -write_event({Time, {info_msg, _GL, {Pid, Format, Args}}},IOMod) -> - T = write_time(maybe_utc(Time), "INFO REPORT"), - case catch io_lib:format(add_node(Format,Pid), Args) of - S when is_list(S) -> - format(IOMod, T ++ S); - _ -> - F = add_node("ERROR: ~p - ~p~n", Pid), - format(IOMod, T ++ F, [Format,Args]) - end; -write_event({Time, {warning_report, _GL, {Pid, std_warning, Rep}}},IOMod) -> - T = write_time(maybe_utc(Time), "WARNING REPORT"), - S = format_report(Rep), - format(IOMod, T ++ S ++ add_node("", Pid)); -write_event({Time, {warning_msg, _GL, {Pid, Format, Args}}},IOMod) -> - T = write_time(maybe_utc(Time), "WARNING REPORT"), - case catch io_lib:format(add_node(Format,Pid), Args) of - S when is_list(S) -> - format(IOMod, T ++ S); - _ -> - F = add_node("ERROR: ~p - ~p~n", Pid), - format(IOMod, T ++ F, [Format,Args]) +do_write_event(#st{modifier=M}=State, {Time, Event}) -> + case parse_event(Event,M) of + ignore -> + ok; + {Title,Pid,FormatList} -> + Header = header(Time, Title, M), + Body = format_body(State, FormatList), + AtNode = if + node(Pid) =/= node() -> + ["** at node ",atom_to_list(node(Pid))," **\n"]; + true -> + [] + end, + Str = [Header,AtNode,Body], + case State#st.io_mod of + io_lib -> + Str; + io -> + io:put_chars(user, Str) + end end; -write_event({_Time, _Error},_IOMod) -> +do_write_event(_, _) -> ok. -maybe_utc(Time) -> - UTC = case application:get_env(sasl, utc_log) of - {ok, Val} -> Val; - undefined -> - %% Backwards compatible: - case application:get_env(stdlib, utc_log) of - {ok, Val} -> Val; - undefined -> false - end - end, - maybe_utc(Time, UTC). - -maybe_utc(Time, true) -> {utc, Time}; -maybe_utc(Time, _) -> {local, calendar:universal_time_to_local_time(Time)}. - -format(IOMod, String) -> format(IOMod, String, []). -format(io_lib, String, Args) -> io_lib:format(String, Args); -format(io, String, Args) -> io:format(user, String, Args). - -format_report(Rep) when is_list(Rep) -> - case string_p(Rep) of +format_body(#st{modifier=M}=State, [{Format,Args}|T]) -> + S = try format(State, Format, Args) of + S0 -> + S0 + catch + _:_ -> + format(State, "ERROR: ~"++M++"p - ~"++M++"p\n", [Format,Args]) + end, + [S|format_body(State, T)]; +format_body(_State, []) -> + []. + +format(#st{depth=unlimited}, Format, Args) -> + io_lib:format(Format, Args); +format(#st{depth=Depth}, Format0, Args) -> + Format1 = io_lib:scan_format(Format0, Args), + Format = limit_format(Format1, Depth), + io_lib:build_text(Format). + +limit_format([#{control_char:=C0}=M0|T], Depth) when C0 =:= $p; + C0 =:= $w -> + C = C0 - ($a - $A), %To uppercase. + #{args:=Args} = M0, + M = M0#{control_char:=C,args:=Args++[Depth]}, + [M|limit_format(T, Depth)]; +limit_format([H|T], Depth) -> + [H|limit_format(T, Depth)]; +limit_format([], _) -> + []. + +parse_event({error, _GL, {Pid, Format, Args}},_) -> + {"ERROR REPORT",Pid,[{Format,Args}]}; +parse_event({info_msg, _GL, {Pid, Format, Args}},_) -> + {"INFO REPORT",Pid,[{Format, Args}]}; +parse_event({warning_msg, _GL, {Pid, Format, Args}},_) -> + {"WARNING REPORT",Pid,[{Format,Args}]}; +parse_event({error_report, _GL, {Pid, std_error, Args}},M) -> + {"ERROR REPORT",Pid,format_term(Args,M)}; +parse_event({info_report, _GL, {Pid, std_info, Args}},M) -> + {"INFO REPORT",Pid,format_term(Args,M)}; +parse_event({warning_report, _GL, {Pid, std_warning, Args}},M) -> + {"WARNING REPORT",Pid,format_term(Args,M)}; +parse_event(_,_) -> ignore. + +format_term(Term,M) when is_list(Term) -> + case string_p(lists:flatten(Term)) of true -> - io_lib:format("~s~n",[Rep]); - _ -> - format_rep(Rep) + [{"~"++M++"s\n",[Term]}]; + false -> + format_term_list(Term,M) end; -format_report(Rep) -> - io_lib:format("~p~n",[Rep]). - -format_rep([{Tag,Data}|Rep]) -> - io_lib:format(" ~p: ~p~n",[Tag,Data]) ++ format_rep(Rep); -format_rep([Other|Rep]) -> - io_lib:format(" ~p~n",[Other]) ++ format_rep(Rep); -format_rep(_) -> - []. +format_term(Term,M) -> + [{"~"++M++"p\n",[Term]}]. -add_node(X, Pid) when is_atom(X) -> - add_node(atom_to_list(X), Pid); -add_node(X, Pid) when node(Pid) =/= node() -> - lists:concat([X,"** at node ",node(Pid)," **~n"]); -add_node(X, _) -> - X. +format_term_list([{Tag,Data}|T],M) -> + [{" ~"++M++"p: ~"++M++"p\n",[Tag,Data]}|format_term_list(T,M)]; +format_term_list([Data|T],M) -> + [{" ~"++M++"p\n",[Data]}|format_term_list(T,M)]; +format_term_list([],_) -> + []. string_p([]) -> false; -string_p(Term) -> - string_p1(Term). - -string_p1([H|T]) when is_integer(H), H >= $\s, H < 255 -> - string_p1(T); -string_p1([$\n|T]) -> string_p1(T); -string_p1([$\r|T]) -> string_p1(T); -string_p1([$\t|T]) -> string_p1(T); -string_p1([$\v|T]) -> string_p1(T); -string_p1([$\b|T]) -> string_p1(T); -string_p1([$\f|T]) -> string_p1(T); -string_p1([$\e|T]) -> string_p1(T); -string_p1([H|T]) when is_list(H) -> - case string_p1(H) of - true -> string_p1(T); - _ -> false - end; -string_p1([]) -> true; -string_p1(_) -> false. +string_p(FlatList) -> + io_lib:printable_list(FlatList). + +get_utc_config() -> + %% SASL utc_log configuration overrides stdlib config + %% in order to have uniform timestamps in log messages + case application:get_env(sasl, utc_log) of + {ok, Val} -> Val; + undefined -> + case application:get_env(stdlib, utc_log) of + {ok, Val} -> Val; + undefined -> false + end + end. + +header(Time, Title, M) -> + case get_utc_config() of + true -> + header(Time, Title, "UTC ", M); + _ -> + header(calendar:universal_time_to_local_time(Time), Title, "", M) + end. -write_time(Time) -> write_time(Time, "ERROR REPORT"). -write_time({utc,{{Y,Mo,D},{H,Mi,S}}},Type) -> - io_lib:format("~n=~s==== ~p-~s-~p::~s:~s:~s UTC ===~n", - [Type,D,month(Mo),Y,t(H),t(Mi),t(S)]); -write_time({local, {{Y,Mo,D},{H,Mi,S}}},Type) -> - io_lib:format("~n=~s==== ~p-~s-~p::~s:~s:~s ===~n", - [Type,D,month(Mo),Y,t(H),t(Mi),t(S)]). +header({{Y,Mo,D},{H,Mi,S}}, Title, UTC, M) -> + io_lib:format("~n=~"++M++"s==== ~p-~s-~p::~s:~s:~s ~s===~n", + [Title,D,month(Mo),Y,t(H),t(Mi),t(S),UTC]). t(X) when is_integer(X) -> t1(integer_to_list(X)); @@ -255,7 +259,12 @@ month(10) -> "Oct"; month(11) -> "Nov"; month(12) -> "Dec". +modifier() -> + modifier(encoding()). +modifier(latin1) -> + ""; +modifier(_) -> + "t". - - - +encoding() -> + proplists:get_value(encoding,io:getopts(),latin1). diff --git a/lib/stdlib/src/escript.erl b/lib/stdlib/src/escript.erl index 41b49f4a86..2b9d8ff65b 100644 --- a/lib/stdlib/src/escript.erl +++ b/lib/stdlib/src/escript.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2007-2015. All Rights Reserved. +%% Copyright Ericsson AB 2007-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -38,7 +38,7 @@ -record(state, {file :: file:filename(), module :: module(), forms_or_bin, - source :: source(), + source :: source() | 'undefined', n_errors :: non_neg_integer(), mode :: mode(), exports_main :: boolean(), @@ -49,9 +49,9 @@ -type emu_args() :: string(). -record(sections, {type, - shebang :: shebang(), - comment :: comment(), - emu_args :: emu_args(), + shebang :: shebang() | 'undefined', + comment :: comment() | 'undefined', + emu_args :: emu_args() | 'undefined', body}). -record(extract_options, {compile_source}). @@ -281,11 +281,12 @@ start(EscriptOptions) -> end catch throw:Str -> - io:format("escript: ~s\n", [Str]), + io:format("escript: ~ts\n", [Str]), my_halt(127); _:Reason -> - io:format("escript: Internal error: ~p\n", [Reason]), - io:format("~p\n", [erlang:get_stacktrace()]), + Stk = erlang:get_stacktrace(), + io:format("escript: Internal error: ~tp\n", [Reason]), + io:format("~tp\n", [Stk]), my_halt(127) end. @@ -481,46 +482,49 @@ find_first_body_line(Fd, HeaderSz0, LineNo, KeepFirst, Sections) -> %% Look for special comment on second line Line2 = get_line(Fd), {ok, HeaderSz2} = file:position(Fd, cur), - case classify_line(Line2) of - emu_args -> - %% Skip special comment on second line - Line3 = get_line(Fd), - {HeaderSz2, LineNo + 2, Fd, - Sections#sections{type = guess_type(Line3), - comment = undefined, - emu_args = Line2}}; - Line2Type -> - %% Look for special comment on third line - Line3 = get_line(Fd), - {ok, HeaderSz3} = file:position(Fd, cur), - Line3Type = classify_line(Line3), - if - Line3Type =:= emu_args -> - %% Skip special comment on third line - Line4 = get_line(Fd), - {HeaderSz3, LineNo + 3, Fd, - Sections#sections{type = guess_type(Line4), - comment = Line2, - emu_args = Line3}}; - Sections#sections.shebang =:= undefined, - KeepFirst =:= true -> - %% No shebang. Use the entire file - {HeaderSz0, LineNo, Fd, - Sections#sections{type = guess_type(Line2)}}; - Sections#sections.shebang =:= undefined -> - %% No shebang. Skip the first line - {HeaderSz1, LineNo, Fd, - Sections#sections{type = guess_type(Line2)}}; - Line2Type =:= comment -> - %% Skip shebang on first line and comment on second - {HeaderSz2, LineNo + 2, Fd, - Sections#sections{type = guess_type(Line3), - comment = Line2}}; - true -> - %% Just skip shebang on first line - {HeaderSz1, LineNo + 1, Fd, - Sections#sections{type = guess_type(Line2)}} - end + if + Sections#sections.shebang =:= undefined, + KeepFirst =:= true -> + %% No shebang. Use the entire file + {HeaderSz0, LineNo, Fd, + Sections#sections{type = guess_type(Line2)}}; + Sections#sections.shebang =:= undefined -> + %% No shebang. Skip the first line + {HeaderSz1, LineNo, Fd, + Sections#sections{type = guess_type(Line2)}}; + true -> + case classify_line(Line2) of + emu_args -> + %% Skip special comment on second line + Line3 = get_line(Fd), + {HeaderSz2, LineNo + 2, Fd, + Sections#sections{type = guess_type(Line3), + comment = undefined, + emu_args = Line2}}; + comment -> + %% Look for special comment on third line + Line3 = get_line(Fd), + {ok, HeaderSz3} = file:position(Fd, cur), + Line3Type = classify_line(Line3), + if + Line3Type =:= emu_args -> + %% Skip special comment on third line + Line4 = get_line(Fd), + {HeaderSz3, LineNo + 3, Fd, + Sections#sections{type = guess_type(Line4), + comment = Line2, + emu_args = Line3}}; + true -> + %% Skip shebang on first line and comment on second + {HeaderSz2, LineNo + 2, Fd, + Sections#sections{type = guess_type(Line3), + comment = Line2}} + end; + _ -> + %% Just skip shebang on first line + {HeaderSz1, LineNo + 1, Fd, + Sections#sections{type = guess_type(Line2)}} + end end. classify_line(Line) -> @@ -626,8 +630,7 @@ parse_source(S, File, Fd, StartLine, HeaderSz, CheckOnly) -> {error, _} -> epp_parse_file2(Epp, S2, [FileForm], OptModRes); {eof, LastLine} -> - Anno = anno(LastLine), - S#state{forms_or_bin = [FileForm, {eof, Anno}]} + S#state{forms_or_bin = [FileForm, {eof, LastLine}]} end, ok = epp:close(Epp), ok = file:close(Fd), @@ -725,8 +728,7 @@ epp_parse_file2(Epp, S, Forms, Parsed) -> [S#state.file,Ln,Mod:format_error(Args)]), epp_parse_file(Epp, S#state{n_errors = S#state.n_errors + 1}, [Form | Forms]); {eof, LastLine} -> - Anno = anno(LastLine), - S#state{forms_or_bin = lists:reverse([{eof, Anno} | Forms])} + S#state{forms_or_bin = lists:reverse([{eof, LastLine} | Forms])} end. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -858,7 +860,7 @@ code_handler(Name, Args, Dict, File) -> %% io:format("Calling:~p~n",[{Mod,Name,Args}]), apply(Mod, Name, Args); error -> - io:format("Script does not export ~w/~w\n", [Name,Arity]), + io:format("Script does not export ~tw/~w\n", [Name,Arity]), my_halt(127) end end. @@ -906,6 +908,7 @@ anno(L) -> fatal(Str) -> throw(Str). +-spec my_halt(_) -> no_return(). my_halt(Reason) -> erlang:halt(Reason). diff --git a/lib/stdlib/src/ets.erl b/lib/stdlib/src/ets.erl index 847def2fd8..42fa8ede92 100644 --- a/lib/stdlib/src/ets.erl +++ b/lib/stdlib/src/ets.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2014. All Rights Reserved. +%% Copyright Ericsson AB 1996-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -51,10 +51,10 @@ -type tab() :: atom() | tid(). -type type() :: set | ordered_set | bag | duplicate_bag. -type continuation() :: '$end_of_table' - | {tab(),integer(),integer(),binary(),list(),integer()} - | {tab(),_,_,integer(),binary(),list(),integer(),integer()}. + | {tab(),integer(),integer(),comp_match_spec(),list(),integer()} + | {tab(),_,_,integer(),comp_match_spec(),list(),integer(),integer()}. --opaque tid() :: integer(). +-opaque tid() :: reference(). -type match_pattern() :: atom() | tuple(). -type match_spec() :: [{match_pattern(), [_], [_]}]. @@ -70,15 +70,33 @@ match_object/2, match_object/3, match_spec_compile/1, match_spec_run_r/3, member/2, new/2, next/2, prev/2, rename/2, safe_fixtable/2, select/1, select/2, select/3, - select_count/2, select_delete/2, select_reverse/1, + select_count/2, select_delete/2, select_replace/2, select_reverse/1, select_reverse/2, select_reverse/3, setopts/2, slot/2, take/2, update_counter/3, update_counter/4, update_element/3]). +%% internal exports +-export([internal_request_all/0]). + -spec all() -> [Tab] when Tab :: tab(). all() -> + receive_all(ets:internal_request_all(), + erlang:system_info(schedulers), + []). + +receive_all(_Ref, 0, All) -> + All; +receive_all(Ref, N, All) -> + receive + {Ref, SchedAll} -> + receive_all(Ref, N-1, SchedAll ++ All) + end. + +-spec internal_request_all() -> reference(). + +internal_request_all() -> erlang:nif_error(undef). -spec delete(Tab) -> true when @@ -146,7 +164,7 @@ info(_) -> Tab :: tab(), Item :: compressed | fixed | heir | keypos | memory | name | named_table | node | owner | protection - | safe_fixed | size | stats | type + | safe_fixed | safe_fixed_monotonic_time | size | stats | type | write_concurrency | read_concurrency, Value :: term(). @@ -232,20 +250,20 @@ match(_) -> match_object(_, _) -> erlang:nif_error(undef). --spec match_object(Tab, Pattern, Limit) -> {[Match], Continuation} | +-spec match_object(Tab, Pattern, Limit) -> {[Object], Continuation} | '$end_of_table' when Tab :: tab(), Pattern :: match_pattern(), Limit :: pos_integer(), - Match :: [term()], + Object :: tuple(), Continuation :: continuation(). match_object(_, _, _) -> erlang:nif_error(undef). --spec match_object(Continuation) -> {[Match], Continuation} | +-spec match_object(Continuation) -> {[Object], Continuation} | '$end_of_table' when - Match :: [term()], + Object :: tuple(), Continuation :: continuation(). match_object(_) -> @@ -259,7 +277,7 @@ match_spec_compile(_) -> erlang:nif_error(undef). -spec match_spec_run_r(List, CompiledMatchSpec, list()) -> list() when - List :: [tuple()], + List :: [term()], CompiledMatchSpec :: comp_match_spec(). match_spec_run_r(_, _, _) -> @@ -361,6 +379,14 @@ select_count(_, _) -> select_delete(_, _) -> erlang:nif_error(undef). +-spec select_replace(Tab, MatchSpec) -> NumReplaced when + Tab :: tab(), + MatchSpec :: match_spec(), + NumReplaced :: non_neg_integer(). + +select_replace(_, _) -> + erlang:nif_error(undef). + -spec select_reverse(Tab, MatchSpec) -> [Match] when Tab :: tab(), MatchSpec :: match_spec(), @@ -488,10 +514,10 @@ update_element(_, _, _) -> %%% End of BIFs --opaque comp_match_spec() :: binary(). %% this one is REALLY opaque +-opaque comp_match_spec() :: reference(). -spec match_spec_run(List, CompiledMatchSpec) -> list() when - List :: [tuple()], + List :: [term()], CompiledMatchSpec :: comp_match_spec(). match_spec_run(List, CompiledMS) -> @@ -505,28 +531,28 @@ match_spec_run(List, CompiledMS) -> repair_continuation('$end_of_table', _) -> '$end_of_table'; %% ordered_set -repair_continuation(Untouched = {Table,Lastkey,EndCondition,N2,Bin,L2,N3,N4}, MS) +repair_continuation(Untouched = {Table,Lastkey,EndCondition,N2,MSRef,L2,N3,N4}, MS) when %% (is_atom(Table) or is_integer(Table)), is_integer(N2), - byte_size(Bin) =:= 0, + %% is_reference(MSRef), is_list(L2), is_integer(N3), is_integer(N4) -> - case ets:is_compiled_ms(Bin) of + case ets:is_compiled_ms(MSRef) of true -> Untouched; false -> {Table,Lastkey,EndCondition,N2,ets:match_spec_compile(MS),L2,N3,N4} end; %% set/bag/duplicate_bag -repair_continuation(Untouched = {Table,N1,N2,Bin,L,N3}, MS) +repair_continuation(Untouched = {Table,N1,N2,MSRef,L,N3}, MS) when %% (is_atom(Table) or is_integer(Table)), is_integer(N1), is_integer(N2), - byte_size(Bin) =:= 0, + %% is_reference(MSRef), is_list(L), is_integer(N3) -> - case ets:is_compiled_ms(Bin) of + case ets:is_compiled_ms(MSRef) of true -> Untouched; false -> @@ -1667,13 +1693,15 @@ choice(Height, Width, P, Mode, Tab, Key, Turn, Opos) -> end, choice(Height, Width, P, Mode, Tab, Key, Turn, Opos); [$/|Regexp] -> %% from regexp - case re:compile(nonl(Regexp)) of + case re:compile(nonl(Regexp),[unicode]) of {ok,Re} -> re_search(Height, Width, Tab, ets:first(Tab), Re, 1, 1); {error,{ErrorString,_Pos}} -> io:format("~ts\n", [ErrorString]), choice(Height, Width, P, Mode, Tab, Key, Turn, Opos) end; + eof -> + ok; _ -> choice(Height, Width, P, Mode, Tab, Key, Turn, Opos) end. diff --git a/lib/stdlib/src/eval_bits.erl b/lib/stdlib/src/eval_bits.erl index b3698fb3f5..631faa3be5 100644 --- a/lib/stdlib/src/eval_bits.erl +++ b/lib/stdlib/src/eval_bits.erl @@ -2,7 +2,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1999-2013. All Rights Reserved. +%% Copyright Ericsson AB 1999-2016. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -67,16 +67,20 @@ expr_grp([Field | FS], Bs0, Lf, Acc) -> expr_grp([], Bs0, _Lf, Acc) -> {value,Acc,Bs0}. +eval_field({bin_element, _, {string, _, S}, {integer,_,8}, [integer,{unit,1},unsigned,big]}, Bs0, _Fun) -> + Latin1 = [C band 16#FF || C <- S], + {list_to_binary(Latin1),Bs0}; eval_field({bin_element, _, {string, _, S}, default, default}, Bs0, _Fun) -> Latin1 = [C band 16#FF || C <- S], {list_to_binary(Latin1),Bs0}; -eval_field({bin_element, Line, {string, _, S}, Size0, Options0}, Bs, _Fun) -> - {_Size,[Type,_Unit,_Sign,Endian]} = +eval_field({bin_element, Line, {string, _, S}, Size0, Options0}, Bs0, Fun) -> + {Size1,[Type,{unit,Unit},Sign,Endian]} = make_bit_type(Line, Size0, Options0), - Res = << <<(eval_exp_field1(C, no_size, no_unit, - Type, Endian, no_sign))/binary>> || + {value,Size,Bs1} = Fun(Size1, Bs0), + Res = << <<(eval_exp_field1(C, Size, Unit, + Type, Endian, Sign))/binary>> || C <- S >>, - {Res,Bs}; + {Res,Bs1}; eval_field({bin_element,Line,E,Size0,Options0}, Bs0, Fun) -> {value,V,Bs1} = Fun(E, Bs0), {Size1,[Type,{unit,Unit},Sign,Endian]} = diff --git a/lib/stdlib/src/file_sorter.erl b/lib/stdlib/src/file_sorter.erl index 47adb133b0..3aeaff8dc4 100644 --- a/lib/stdlib/src/file_sorter.erl +++ b/lib/stdlib/src/file_sorter.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2001-2013. All Rights Reserved. +%% Copyright Ericsson AB 2001-2016. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -28,6 +28,8 @@ check/1, check/2, keycheck/2, keycheck/3]). +-dialyzer(no_improper_lists). + -include_lib("kernel/include/file.hrl"). -define(CHUNKSIZE, 16384). @@ -305,7 +307,6 @@ options(Option) -> options([{format, Format} | L], Opts) when Format =:= binary; Format =:= term; - is_function(Format), is_function(Format, 1) -> options(L, Opts#opts{format = Format}); options([{format, binary_term} | L], Opts) -> @@ -324,7 +325,7 @@ options([{tmpdir, Dir} | L], Opts) -> FileName -> options(L, Opts#opts{tmpdir = {dir, FileName}}) end; -options([{order, Fun} | L], Opts) when is_function(Fun), is_function(Fun, 2) -> +options([{order, Fun} | L], Opts) when is_function(Fun, 2) -> options(L, Opts#opts{order = Fun}); options([{order, Order} | L], Opts) when Order =:= ascending; Order =:= descending -> @@ -409,7 +410,7 @@ merge_terms_fun(RFun) -> case RFun(read) of end_of_input -> eof; - {Objs, NRFun} when is_function(NRFun), is_function(NRFun, 1) -> + {Objs, NRFun} when is_function(NRFun, 1) -> {_, [], Ts, _} = fun_objs(Objs, [], 0, ?MAXSIZE, I, W), {{I, Ts, ?CHUNKSIZE}, merge_terms_fun(NRFun)}; Error -> @@ -425,13 +426,12 @@ merge_bins_fun(FileName) -> Fun(A) end. -wrap_output_terms(term, OutFun, _Z) when is_function(OutFun), - is_function(OutFun, 1) -> +wrap_output_terms(term, OutFun, _Z) when is_function(OutFun, 1) -> {fun_wterms(OutFun), true}; wrap_output_terms(term, File, Z) when File =/= undefined -> {file_wterms(name, File, Z++[write]), false}; wrap_output_terms(_Format, Output, _Z) -> - {Output, is_function(Output) and is_function(Output, 1)}. + {Output, is_function(Output, 1)}. binary_term_fun() -> fun binary_to_term/1. @@ -1309,8 +1309,7 @@ infun(W) -> {end_of_input, W1}; {end_of_input, Value} -> {end_of_input, W1#w{inout_value = {value, Value}}}; - {Objs, NFun} when is_function(NFun), - is_function(NFun, 1), + {Objs, NFun} when is_function(NFun, 1), is_list(Objs) -> {cont, W#w{in = NFun}, Objs}; Error -> @@ -1333,7 +1332,7 @@ outfun(A, W) -> try (W#w.out)(A) of Reply when A =:= close -> Reply; - NF when is_function(NF), is_function(NF, 1) -> + NF when is_function(NF, 1) -> W#w{out = NF}; Error -> error(Error, W1) @@ -1358,7 +1357,7 @@ is_keyposs([Bad | _]) -> is_keyposs(Bad) -> {badarg, Bad}. -is_input(Fun) when is_function(Fun), is_function(Fun, 1) -> +is_input(Fun) when is_function(Fun, 1) -> {true, Fun}; is_input(Files) -> is_files(Files). @@ -1378,7 +1377,7 @@ is_files([], L) -> is_files(Bad, _L) -> {badarg, Bad}. -maybe_output(Fun) when is_function(Fun), is_function(Fun, 1) -> +maybe_output(Fun) when is_function(Fun, 1) -> {true, Fun}; maybe_output(File) -> case read_file_info(File) of @@ -1587,7 +1586,6 @@ fun_rterms(InFun) -> (read) -> case InFun(read) of {Ts, NInFun} when is_list(Ts), - is_function(NInFun), is_function(NInFun, 1) -> {to_bin(Ts, []), fun_rterms(NInFun)}; Else -> @@ -1600,7 +1598,7 @@ fun_wterms(OutFun) -> OutFun(close); (L) -> case OutFun(wterms_arg(L)) of - NOutFun when is_function(NOutFun), is_function(NOutFun, 1) -> + NOutFun when is_function(NOutFun, 1) -> fun_wterms(NOutFun); Else -> Else diff --git a/lib/stdlib/src/filelib.erl b/lib/stdlib/src/filelib.erl index 51ffd1cff9..a9c055f72d 100644 --- a/lib/stdlib/src/filelib.erl +++ b/lib/stdlib/src/filelib.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1997-2013. All Rights Reserved. +%% Copyright Ericsson AB 1997-2018. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -24,6 +24,7 @@ -export([fold_files/5, last_modified/1, file_size/1, ensure_dir/1]). -export([wildcard/3, is_dir/2, is_file/2, is_regular/2]). -export([fold_files/6, last_modified/2, file_size/2]). +-export([find_file/2, find_file/3, find_source/1, find_source/2, find_source/3]). %% For debugging/testing. -export([compile_wildcard/1]). @@ -517,3 +518,131 @@ eval_list_dir(Dir, erl_prim_loader) -> end; eval_list_dir(Dir, Mod) -> Mod:list_dir(Dir). + +%% Getting the rules to use for file search + +keep_dir_search_rules(Rules) -> + [T || {_,_}=T <- Rules]. + +keep_suffix_search_rules(Rules) -> + [T || {_,_,_}=T <- Rules]. + +get_search_rules() -> + case application:get_env(kernel, source_search_rules) of + undefined -> default_search_rules(); + {ok, []} -> default_search_rules(); + {ok, R} when is_list(R) -> R + end. + +default_search_rules() -> + [%% suffix-speficic rules for source search + {".beam", ".erl", erl_source_search_rules()}, + {".erl", ".yrl", []}, + {"", ".src", erl_source_search_rules()}, + {".so", ".c", c_source_search_rules()}, + {".o", ".c", c_source_search_rules()}, + {"", ".c", c_source_search_rules()}, + {"", ".in", basic_source_search_rules()}, + %% plain old directory rules, backwards compatible + {"", ""}] ++ erl_source_search_rules(). + +basic_source_search_rules() -> + (erl_source_search_rules() + ++ c_source_search_rules()). + +erl_source_search_rules() -> + [{"ebin","src"}, {"ebin","esrc"}, + {"ebin",filename:join("src", "*")}, + {"ebin",filename:join("esrc", "*")}]. + +c_source_search_rules() -> + [{"priv","c_src"}, {"priv","src"}, {"bin","c_src"}, {"bin","src"}, {"", "src"}]. + +%% Looks for a file relative to a given directory + +-type find_file_rule() :: {ObjDirSuffix::string(), SrcDirSuffix::string()}. + +-spec find_file(filename(), filename()) -> + {ok, filename()} | {error, not_found}. +find_file(Filename, Dir) -> + find_file(Filename, Dir, []). + +-spec find_file(filename(), filename(), [find_file_rule()]) -> + {ok, filename()} | {error, not_found}. +find_file(Filename, Dir, []) -> + find_file(Filename, Dir, get_search_rules()); +find_file(Filename, Dir, Rules) -> + try_dir_rules(keep_dir_search_rules(Rules), Filename, Dir). + +%% Looks for a source file relative to the object file name and directory + +-type find_source_rule() :: {ObjExtension::string(), SrcExtension::string(), + [find_file_rule()]}. + +-spec find_source(filename()) -> + {ok, filename()} | {error, not_found}. +find_source(FilePath) -> + find_source(filename:basename(FilePath), filename:dirname(FilePath)). + +-spec find_source(filename(), filename()) -> + {ok, filename()} | {error, not_found}. +find_source(Filename, Dir) -> + find_source(Filename, Dir, []). + +-spec find_source(filename(), filename(), [find_source_rule()]) -> + {ok, filename()} | {error, not_found}. +find_source(Filename, Dir, []) -> + find_source(Filename, Dir, get_search_rules()); +find_source(Filename, Dir, Rules) -> + try_suffix_rules(keep_suffix_search_rules(Rules), Filename, Dir). + +try_suffix_rules(Rules, Filename, Dir) -> + Ext = filename:extension(Filename), + try_suffix_rules(Rules, filename:rootname(Filename, Ext), Dir, Ext). + +try_suffix_rules([{Ext,Src,Rules}|Rest], Root, Dir, Ext) + when is_list(Src), is_list(Rules) -> + case try_dir_rules(add_local_search(Rules), Root ++ Src, Dir) of + {ok, File} -> {ok, File}; + _Other -> + try_suffix_rules(Rest, Root, Dir, Ext) + end; +try_suffix_rules([_|Rest], Root, Dir, Ext) -> + try_suffix_rules(Rest, Root, Dir, Ext); +try_suffix_rules([], _Root, _Dir, _Ext) -> + {error, not_found}. + +%% ensuring we check the directory of the object file before any other directory +add_local_search(Rules) -> + Local = {"",""}, + [Local] ++ lists:filter(fun (X) -> X =/= Local end, Rules). + +try_dir_rules([{From, To}|Rest], Filename, Dir) + when is_list(From), is_list(To) -> + case try_dir_rule(Dir, Filename, From, To) of + {ok, File} -> {ok, File}; + error -> try_dir_rules(Rest, Filename, Dir) + end; +try_dir_rules([], _Filename, _Dir) -> + {error, not_found}. + +try_dir_rule(Dir, Filename, From, To) -> + case lists:suffix(From, Dir) of + true -> + NewDir = lists:sublist(Dir, 1, length(Dir)-length(From))++To, + Src = filename:join(NewDir, Filename), + case is_regular(Src) of + true -> {ok, Src}; + false -> find_regular_file(wildcard(Src)) + end; + false -> + error + end. + +find_regular_file([]) -> + error; +find_regular_file([File|Files]) -> + case is_regular(File) of + true -> {ok, File}; + false -> find_regular_file(Files) + end. diff --git a/lib/stdlib/src/filename.erl b/lib/stdlib/src/filename.erl index 008beb8b67..ee807dfd09 100644 --- a/lib/stdlib/src/filename.erl +++ b/lib/stdlib/src/filename.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1997-2014. All Rights Reserved. +%% Copyright Ericsson AB 1997-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -19,6 +19,9 @@ %% -module(filename). +-deprecated({find_src,1,next_major_release}). +-deprecated({find_src,2,next_major_release}). + %% Purpose: Provides generic manipulation of filenames. %% %% Generally, these functions accept filenames in the native format @@ -34,8 +37,10 @@ -export([absname/1, absname/2, absname_join/2, basename/1, basename/2, dirname/1, extension/1, join/1, join/2, pathtype/1, - rootname/1, rootname/2, split/1, nativename/1]). --export([find_src/1, find_src/2, flatten/1]). + rootname/1, rootname/2, split/1, flatten/1, nativename/1, + safe_relative_path/1]). +-export([find_src/1, find_src/2]). % deprecated +-export([basedir/2, basedir/3]). %% Undocumented and unsupported exports. -export([append/2]). @@ -139,6 +144,7 @@ absname_join(AbsBase, Name) -> -spec basename(Filename) -> file:filename_all() when Filename :: file:name_all(). + basename(Name) when is_binary(Name) -> case os:type() of {win32,_} -> @@ -433,6 +439,10 @@ join(Name1, Name2) when is_atom(Name2) -> join1([UcLetter, $:|Rest], RelativeName, [], win32) when is_integer(UcLetter), UcLetter >= $A, UcLetter =< $Z -> join1(Rest, RelativeName, [$:, UcLetter+$a-$A], win32); +join1([$\\,$\\|Rest], RelativeName, [], win32) -> + join1([$/,$/|Rest], RelativeName, [], win32); +join1([$/,$/|Rest], RelativeName, [], win32) -> + join1(Rest, RelativeName, [$/,$/], win32); join1([$\\|Rest], RelativeName, Result, win32) -> join1([$/|Rest], RelativeName, Result, win32); join1([$/|Rest], RelativeName, [$., $/|Result], OsType) -> @@ -461,6 +471,10 @@ join1([Atom|Rest], RelativeName, Result, OsType) when is_atom(Atom) -> join1b(<<UcLetter, $:, Rest/binary>>, RelativeName, [], win32) when is_integer(UcLetter), UcLetter >= $A, UcLetter =< $Z -> join1b(Rest, RelativeName, [$:, UcLetter+$a-$A], win32); +join1b(<<$\\,$\\,Rest/binary>>, RelativeName, [], win32) -> + join1b(<<$/,$/,Rest/binary>>, RelativeName, [], win32); +join1b(<<$/,$/,Rest/binary>>, RelativeName, [], win32) -> + join1b(Rest, RelativeName, [$/,$/], win32); join1b(<<$\\,Rest/binary>>, RelativeName, Result, win32) -> join1b(<<$/,Rest/binary>>, RelativeName, Result, win32); join1b(<<$/,Rest/binary>>, RelativeName, [$., $/|Result], OsType) -> @@ -471,6 +485,8 @@ join1b(<<>>, <<>>, Result, OsType) -> list_to_binary(maybe_remove_dirsep(Result, OsType)); join1b(<<>>, RelativeName, [$:|Rest], win32) -> join1b(RelativeName, <<>>, [$:|Rest], win32); +join1b(<<>>, RelativeName, [$/,$/|Result], win32) -> + join1b(RelativeName, <<>>, [$/,$/|Result], win32); join1b(<<>>, RelativeName, [$/|Result], OsType) -> join1b(RelativeName, <<>>, [$/|Result], OsType); join1b(<<>>, RelativeName, [$., $/|Result], OsType) -> @@ -484,6 +500,8 @@ maybe_remove_dirsep([$/, $:, Letter], win32) -> [Letter, $:, $/]; maybe_remove_dirsep([$/], _) -> [$/]; +maybe_remove_dirsep([$/,$/], win32) -> + [$/,$/]; maybe_remove_dirsep([$/|Name], _) -> lists:reverse(Name); maybe_remove_dirsep(Name, _) -> @@ -673,6 +691,9 @@ win32_splitb(<<Letter0,$:,Rest/binary>>) when ?IS_DRIVELETTER(Letter0) -> Letter = fix_driveletter(Letter0), L = binary:split(Rest,[<<"/">>,<<"\\">>],[global]), [<<Letter,$:>> | [ X || X <- L, X =/= <<>> ]]; +win32_splitb(<<Slash,Slash,Rest/binary>>) when ((Slash =:= $\\) orelse (Slash =:= $/)) -> + L = binary:split(Rest,[<<"/">>,<<"\\">>],[global]), + [<<"//">> | [ X || X <- L, X =/= <<>> ]]; win32_splitb(<<Slash,Rest/binary>>) when ((Slash =:= $\\) orelse (Slash =:= $/)) -> L = binary:split(Rest,[<<"/">>,<<"\\">>],[global]), [<<$/>> | [ X || X <- L, X =/= <<>> ]]; @@ -684,6 +705,8 @@ win32_splitb(Name) -> unix_split(Name) -> split(Name, [], unix). +win32_split([Slash,Slash|Rest]) when ((Slash =:= $\\) orelse (Slash =:= $/)) -> + split(Rest, [[$/,$/]], win32); win32_split([$\\|Rest]) -> win32_split([$/|Rest]); win32_split([X, $\\|Rest]) when is_integer(X) -> @@ -748,7 +771,45 @@ separators() -> _ -> {false, false} end. +-spec safe_relative_path(Filename) -> 'unsafe' | SafeFilename when + Filename :: file:name_all(), + SafeFilename :: file:name_all(). + +safe_relative_path(Path) -> + case pathtype(Path) of + relative -> + Cs0 = split(Path), + safe_relative_path_1(Cs0, []); + _ -> + unsafe + end. +safe_relative_path_1(["."|T], Acc) -> + safe_relative_path_1(T, Acc); +safe_relative_path_1([<<".">>|T], Acc) -> + safe_relative_path_1(T, Acc); +safe_relative_path_1([".."|T], Acc) -> + climb(T, Acc); +safe_relative_path_1([<<"..">>|T], Acc) -> + climb(T, Acc); +safe_relative_path_1([H|T], Acc) -> + safe_relative_path_1(T, [H|Acc]); +safe_relative_path_1([], []) -> + []; +safe_relative_path_1([], Acc) -> + join(lists:reverse(Acc)). + +climb(_, []) -> + unsafe; +climb(T, [_|Acc]) -> + safe_relative_path_1(T, Acc). + +%% NOTE: The find_src/1/2 functions are deprecated; they try to do too much +%% at once and are not a good fit for this module. Parts of the code have +%% been moved to filelib:find_file/2 instead. Only this part of this +%% module is allowed to call the filelib module; such mutual dependency +%% should otherwise be avoided! This code should eventually be removed. +%% %% find_src(Module) -- %% find_src(Module, Rules) -- @@ -791,14 +852,7 @@ separators() -> | {'d', atom()}, ErrorReason :: 'non_existing' | 'preloaded' | 'interpreted'. find_src(Mod) -> - Default = [{"", ""}, {"ebin", "src"}, {"ebin", "esrc"}], - Rules = - case application:get_env(kernel, source_search_rules) of - undefined -> Default; - {ok, []} -> Default; - {ok, R} when is_list(R) -> R - end, - find_src(Mod, Rules). + find_src(Mod, []). -spec find_src(Beam, Rules) -> {SourceFile, Options} | {error, {ErrorReason, Module}} when @@ -814,44 +868,47 @@ find_src(Mod) -> ErrorReason :: 'non_existing' | 'preloaded' | 'interpreted'. find_src(Mod, Rules) when is_atom(Mod) -> find_src(atom_to_list(Mod), Rules); -find_src(File0, Rules) when is_list(File0) -> - Mod = list_to_atom(basename(File0, ".erl")), - File = rootname(File0, ".erl"), - case readable_file(File++".erl") of - true -> - try_file(File, Mod, Rules); - false -> - try_file(undefined, Mod, Rules) - end. - -try_file(File, Mod, Rules) -> +find_src(ModOrFile, Rules) when is_list(ModOrFile) -> + Extension = ".erl", + Mod = list_to_atom(basename(ModOrFile, Extension)), case code:which(Mod) of Possibly_Rel_Path when is_list(Possibly_Rel_Path) -> - {ok, Cwd} = file:get_cwd(), - Path = join(Cwd, Possibly_Rel_Path), - try_file(File, Path, Mod, Rules); + {ok, Cwd} = file:get_cwd(), + ObjPath = make_abs_path(Cwd, Possibly_Rel_Path), + find_src_1(ModOrFile, ObjPath, Mod, Extension, Rules); Ecode when is_atom(Ecode) -> % Ecode :: ecode() {error, {Ecode, Mod}} end. %% At this point, the Mod is known to be valid. %% If the source name is not known, find it. -%% Then get the compilation options. -%% Returns: {SrcFile, Options} +find_src_1(ModOrFile, ObjPath, Mod, Extension, Rules) -> + %% The documentation says this function must return the found path + %% without extension in all cases. Also, ModOrFile could be given with + %% or without extension. Hence the calls to rootname below. + ModOrFileRoot = rootname(ModOrFile, Extension), + case filelib:is_regular(ModOrFileRoot++Extension) of + true -> + find_src_2(ModOrFileRoot, Mod); + false -> + SrcName = basename(ObjPath, code:objfile_extension()) ++ Extension, + case filelib:find_file(SrcName, dirname(ObjPath), Rules) of + {ok, SrcFile} -> + find_src_2(rootname(SrcFile, Extension), Mod); + Error -> + Error + end + end. -try_file(undefined, ObjFilename, Mod, Rules) -> - case get_source_file(ObjFilename, Mod, Rules) of - {ok, File} -> try_file(File, ObjFilename, Mod, Rules); - Error -> Error - end; -try_file(Src, _ObjFilename, Mod, _Rules) -> +%% Get the compilation options and return {SrcFileRoot, Options} +find_src_2(SrcRoot, Mod) -> List = case Mod:module_info(compile) of none -> []; List0 -> List0 end, Options = proplists:get_value(options, List, []), {ok, Cwd} = file:get_cwd(), - AbsPath = make_abs_path(Cwd, Src), + AbsPath = make_abs_path(Cwd, SrcRoot), {AbsPath, filter_options(dirname(AbsPath), Options, [])}. %% Filters the options. @@ -882,42 +939,6 @@ filter_options(Base, [_|Rest], Result) -> filter_options(_Base, [], Result) -> Result. -%% Gets the source file given path of object code and module name. - -get_source_file(Obj, Mod, Rules) -> - source_by_rules(dirname(Obj), atom_to_list(Mod), Rules). - -source_by_rules(Dir, Base, [{From, To}|Rest]) -> - case try_rule(Dir, Base, From, To) of - {ok, File} -> {ok, File}; - error -> source_by_rules(Dir, Base, Rest) - end; -source_by_rules(_Dir, _Base, []) -> - {error, source_file_not_found}. - -try_rule(Dir, Base, From, To) -> - case lists:suffix(From, Dir) of - true -> - NewDir = lists:sublist(Dir, 1, length(Dir)-length(From))++To, - Src = join(NewDir, Base), - case readable_file(Src++".erl") of - true -> {ok, Src}; - false -> error - end; - false -> - error - end. - -readable_file(File) -> - case file:read_file_info(File) of - {ok, #file_info{type=regular, access=read}} -> - true; - {ok, #file_info{type=regular, access=read_write}} -> - true; - _Other -> - false - end. - make_abs_path(BasePath, Path) -> join(BasePath, Path). @@ -954,3 +975,180 @@ filename_string_to_binary(List) -> Bin end. +%% Application Base Directories +%% basedir +%% http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html + +-type basedir_type() :: 'user_cache' | 'user_config' | 'user_data' + | 'user_log' + | 'site_config' | 'site_data'. + +-spec basedir(Type,Application) -> file:filename_all() when + Type :: basedir_type(), + Application :: string() | binary(). + +basedir(Type,Application) when is_atom(Type), is_list(Application) orelse + is_binary(Application) -> + basedir(Type, Application, #{}). + +-spec basedir(Type,Application,Opts) -> file:filename_all() when + Type :: basedir_type(), + Application :: string() | binary(), + Opts :: #{author => string() | binary(), + os => 'windows' | 'darwin' | 'linux', + version => string() | binary()}. + +basedir(Type,Application,Opts) when is_atom(Type), is_map(Opts), + is_list(Application) orelse + is_binary(Application) -> + Os = basedir_os_from_opts(Opts), + Name = basedir_name_from_opts(Os,Application,Opts), + Base = basedir_from_os(Type,Os), + case {Type,Os} of + {user_log,linux} -> + filename:join([Base,Name,"log"]); + {user_log,windows} -> + filename:join([Base,Name,"Logs"]); + {user_cache,windows} -> + filename:join([Base,Name,"Cache"]); + {Type,_} when Type =:= site_config orelse Type =:= site_data -> + [filename:join([B,Name]) || B <- Base]; + _ -> + filename:join([Base,Name]) + end. + +basedir_os_from_opts(#{os := linux}) -> linux; +basedir_os_from_opts(#{os := windows}) -> windows; +basedir_os_from_opts(#{os := darwin}) -> darwin; +basedir_os_from_opts(#{}) -> basedir_os_type(). + +basedir_name_from_opts(windows,App,#{author:=Author,version:=Vsn}) -> + filename:join([Author,App,Vsn]); +basedir_name_from_opts(windows,App,#{author:=Author}) -> + filename:join([Author,App]); +basedir_name_from_opts(_,App,#{version:=Vsn}) -> + filename:join([App,Vsn]); +basedir_name_from_opts(_,App,_) -> + App. + +basedir_from_os(Type,Os) -> + case Os of + linux -> basedir_linux(Type); + darwin -> basedir_darwin(Type); + windows -> basedir_windows(Type) + end. + +-define(basedir_linux_user_data, ".local/share"). +-define(basedir_linux_user_config, ".config"). +-define(basedir_linux_user_cache, ".cache"). +-define(basedir_linux_user_log, ".cache"). %% .cache/App/log +-define(basedir_linux_site_data, "/usr/local/share/:/usr/share/"). +-define(basedir_linux_site_config, "/etc/xdg"). + +basedir_linux(Type) -> + case Type of + user_data -> getenv("XDG_DATA_HOME", ?basedir_linux_user_data, true); + user_config -> getenv("XDG_CONFIG_HOME",?basedir_linux_user_config,true); + user_cache -> getenv("XDG_CACHE_HOME", ?basedir_linux_user_cache, true); + user_log -> getenv("XDG_CACHE_HOME", ?basedir_linux_user_log, true); + site_data -> + Base = getenv("XDG_DATA_DIRS",?basedir_linux_site_data,false), + string:tokens(Base,":"); + site_config -> + Base = getenv("XDG_CONFIG_DIRS",?basedir_linux_site_config,false), + string:tokens(Base,":") + end. + +-define(basedir_darwin_user_data, "Library/Application Support"). +-define(basedir_darwin_user_config, "Library/Application Support"). +-define(basedir_darwin_user_cache, "Library/Caches"). +-define(basedir_darwin_user_log, "Library/Logs"). +-define(basedir_darwin_site_data, "/Library/Application Support"). +-define(basedir_darwin_site_config, "/Library/Application Support"). + +basedir_darwin(Type) -> + case Type of + user_data -> basedir_join_home(?basedir_darwin_user_data); + user_config -> basedir_join_home(?basedir_darwin_user_config); + user_cache -> basedir_join_home(?basedir_darwin_user_cache); + user_log -> basedir_join_home(?basedir_darwin_user_log); + site_data -> [?basedir_darwin_site_data]; + site_config -> [?basedir_darwin_site_config] + end. + +%% On Windows: +%% ex. C:\Users\egil\AppData\Local\Ericsson\Erlang +%% %LOCALAPPDATA% is defined on Windows 7 and onwards +%% %APPDATA% is used instead of %LOCALAPPDATA% if it's not defined. +%% %APPDATA% is used for roaming, i.e. for user_config on Windows 7 and beyond. +%% +%% user_data %LOCALAPPDATA%[/$author]/$appname[/$version] +%% user_config %APPDATA%[/$author]/$appname[/$version] +%% user_cache %LOCALAPPDATA%[/$author]/$appname[/$version]/Cache +%% user_log %LOCALAPPDATA%[/$author]/$appname[/$version]/Logs + +-define(basedir_windows_user_data, "Local"). +-define(basedir_windows_user_config, "Roaming"). +-define(basedir_windows_user_cache, "Local"). %% Cache is added later +-define(basedir_windows_user_log, "Local"). %% Logs is added later + +basedir_windows(Type) -> + %% If LOCALAPPDATA is not defined we are likely on an + %% XP machine. Use APPDATA instead. + case basedir_windows_appdata() of + noappdata -> + %% No AppData is set + %% Probably running MSYS + case Type of + user_data -> basedir_join_home(?basedir_windows_user_data); + user_config -> basedir_join_home(?basedir_windows_user_config); + user_cache -> basedir_join_home(?basedir_windows_user_cache); + user_log -> basedir_join_home(?basedir_windows_user_log); + site_data -> []; + site_config -> [] + end; + {ok, AppData} -> + case Type of + user_data -> getenv("LOCALAPPDATA", AppData); + user_config -> AppData; + user_cache -> getenv("LOCALAPPDATA", AppData); + user_log -> getenv("LOCALAPPDATA", AppData); + site_data -> []; + site_config -> [] + end + end. + +basedir_windows_appdata() -> + case os:getenv("APPDATA") of + Invalid when Invalid =:= false orelse Invalid =:= [] -> + noappdata; + Val -> + {ok, Val} + end. + +%% basedir aux + +getenv(K,Def,false) -> getenv(K,Def); +getenv(K,Def,true) -> getenv(K,basedir_join_home(Def)). + +getenv(K,Def) -> + case os:getenv(K) of + [] -> Def; + false -> Def; + Val -> Val + end. + +basedir_join_home(Dir) -> + case os:getenv("HOME") of + false -> + {ok,[[Home]]} = init:get_argument(home), + filename:join(Home,Dir); + Home -> filename:join(Home,Dir) + end. + +basedir_os_type() -> + case os:type() of + {unix,darwin} -> darwin; + {win32,_} -> windows; + _ -> linux + end. diff --git a/lib/stdlib/src/gb_sets.erl b/lib/stdlib/src/gb_sets.erl index 47a8fa6db0..6d6f7d40ac 100644 --- a/lib/stdlib/src/gb_sets.erl +++ b/lib/stdlib/src/gb_sets.erl @@ -1,8 +1,3 @@ -%% -%% %CopyrightBegin% -%% -%% Copyright Ericsson AB 2001-2015. All Rights Reserved. -%% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. %% You may obtain a copy of the License at @@ -14,8 +9,6 @@ %% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. %% See the License for the specific language governing permissions and %% limitations under the License. -%% -%% %CopyrightEnd% %% %% ===================================================================== %% Ordered Sets implemented as General Balanced Trees diff --git a/lib/stdlib/src/gb_trees.erl b/lib/stdlib/src/gb_trees.erl index c4a20d92a7..c0cdde012e 100644 --- a/lib/stdlib/src/gb_trees.erl +++ b/lib/stdlib/src/gb_trees.erl @@ -1,8 +1,3 @@ -%% -%% %CopyrightBegin% -%% -%% Copyright Ericsson AB 2001-2015. All Rights Reserved. -%% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. %% You may obtain a copy of the License at @@ -14,8 +9,6 @@ %% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. %% See the License for the specific language governing permissions and %% limitations under the License. -%% -%% %CopyrightEnd% %% %% ===================================================================== %% General Balanced Trees - highly efficient dictionaries. @@ -59,6 +52,13 @@ %% - delete_any(X, T): removes key X from tree T if the key is present %% in the tree, otherwise does nothing; returns new tree. %% +%% - take(X, T): removes element with key X from tree T; returns new tree +%% without removed element. Assumes that the key is present in the tree. +%% +%% - take_any(X, T): removes element with key X from tree T and returns +%% a new tree if the key is present; otherwise does nothing and returns +%% 'error'. +%% %% - balance(T): rebalances tree T. Note that this is rarely necessary, %% but may be motivated when a large number of entries have been %% deleted from the tree without further insertions. Rebalancing could @@ -121,7 +121,8 @@ -export([empty/0, is_empty/1, size/1, lookup/2, get/2, insert/3, update/3, enter/3, delete/2, delete_any/2, balance/1, is_defined/2, keys/1, values/1, to_list/1, from_orddict/1, - smallest/1, largest/1, take_smallest/1, take_largest/1, + smallest/1, largest/1, take/2, take_any/2, + take_smallest/1, take_largest/1, iterator/1, iterator_from/2, next/1, map/2]). @@ -423,6 +424,41 @@ merge(Smaller, Larger) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +-spec take_any(Key, Tree1) -> {Value, Tree2} | 'error' when + Tree1 :: tree(Key, _), + Tree2 :: tree(Key, _), + Key :: term(), + Value :: term(). + +take_any(Key, Tree) -> + case is_defined(Key, Tree) of + true -> take(Key, Tree); + false -> error + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +-spec take(Key, Tree1) -> {Value, Tree2} when + Tree1 :: tree(Key, _), + Tree2 :: tree(Key, _), + Key :: term(), + Value :: term(). + +take(Key, {S, T}) when is_integer(S), S >= 0 -> + {Value, Res} = take_1(Key, T), + {Value, {S - 1, Res}}. + +take_1(Key, {Key1, Value, Smaller, Larger}) when Key < Key1 -> + {Value2, Smaller1} = take_1(Key, Smaller), + {Value2, {Key1, Value, Smaller1, Larger}}; +take_1(Key, {Key1, Value, Smaller, Bigger}) when Key > Key1 -> + {Value2, Bigger1} = take_1(Key, Bigger), + {Value2, {Key1, Value, Smaller, Bigger1}}; +take_1(_, {_Key, Value, Smaller, Larger}) -> + {Value, merge(Smaller, Larger)}. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + -spec take_smallest(Tree1) -> {Key, Value, Tree2} when Tree1 :: tree(Key, Value), Tree2 :: tree(Key, Value). diff --git a/lib/stdlib/src/gen.erl b/lib/stdlib/src/gen.erl index a05c2ce6fd..33af0aed8f 100644 --- a/lib/stdlib/src/gen.erl +++ b/lib/stdlib/src/gen.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2014. All Rights Reserved. +%% Copyright Ericsson AB 1996-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -26,7 +26,8 @@ %%% %%% The standard behaviour should export init_it/6. %%%----------------------------------------------------------------- --export([start/5, start/6, debug_options/1, +-export([start/5, start/6, debug_options/2, hibernate_after/1, + name/1, unregister_name/1, get_proc_name/1, get_parent/0, call/3, call/4, reply/2, stop/1, stop/3]). -export([init_it/6, init_it/7]). @@ -124,7 +125,7 @@ init_it(GenMod, Starter, Parent, Mod, Args, Options) -> init_it2(GenMod, Starter, Parent, self(), Mod, Args, Options). init_it(GenMod, Starter, Parent, Name, Mod, Args, Options) -> - case name_register(Name) of + case register_name(Name) of true -> init_it2(GenMod, Starter, Parent, Name, Mod, Args, Options); {false, Pid} -> @@ -297,19 +298,19 @@ where({global, Name}) -> global:whereis_name(Name); where({via, Module, Name}) -> Module:whereis_name(Name); where({local, Name}) -> whereis(Name). -name_register({local, Name} = LN) -> +register_name({local, Name} = LN) -> try register(Name, self()) of true -> true catch error:_ -> {false, where(LN)} end; -name_register({global, Name} = GN) -> +register_name({global, Name} = GN) -> case global:register_name(Name, self()) of yes -> true; no -> {false, where(GN)} end; -name_register({via, Module, Name} = GN) -> +register_name({via, Module, Name} = GN) -> case Module:register_name(Name, self()) of yes -> true; @@ -317,34 +318,116 @@ name_register({via, Module, Name} = GN) -> {false, where(GN)} end. +name({local,Name}) -> Name; +name({global,Name}) -> Name; +name({via,_, Name}) -> Name; +name(Pid) when is_pid(Pid) -> Pid. + +unregister_name({local,Name}) -> + try unregister(Name) of + _ -> ok + catch + _:_ -> ok + end; +unregister_name({global,Name}) -> + _ = global:unregister_name(Name), + ok; +unregister_name({via, Mod, Name}) -> + _ = Mod:unregister_name(Name), + ok; +unregister_name(Pid) when is_pid(Pid) -> + ok. + +get_proc_name(Pid) when is_pid(Pid) -> + Pid; +get_proc_name({local, Name}) -> + case process_info(self(), registered_name) of + {registered_name, Name} -> + Name; + {registered_name, _Name} -> + exit(process_not_registered); + [] -> + exit(process_not_registered) + end; +get_proc_name({global, Name}) -> + case global:whereis_name(Name) of + undefined -> + exit(process_not_registered_globally); + Pid when Pid =:= self() -> + Name; + _Pid -> + exit(process_not_registered_globally) + end; +get_proc_name({via, Mod, Name}) -> + case Mod:whereis_name(Name) of + undefined -> + exit({process_not_registered_via, Mod}); + Pid when Pid =:= self() -> + Name; + _Pid -> + exit({process_not_registered_via, Mod}) + end. + +get_parent() -> + case get('$ancestors') of + [Parent | _] when is_pid(Parent) -> + Parent; + [Parent | _] when is_atom(Parent) -> + name_to_pid(Parent); + _ -> + exit(process_was_not_started_by_proc_lib) + end. + +name_to_pid(Name) -> + case whereis(Name) of + undefined -> + case global:whereis_name(Name) of + undefined -> + exit(could_not_find_registered_name); + Pid -> + Pid + end; + Pid -> + Pid + end. + timeout(Options) -> - case opt(timeout, Options) of - {ok, Time} -> + case lists:keyfind(timeout, 1, Options) of + {_,Time} -> Time; - _ -> + false -> infinity end. spawn_opts(Options) -> - case opt(spawn_opt, Options) of - {ok, Opts} -> + case lists:keyfind(spawn_opt, 1, Options) of + {_,Opts} -> Opts; - _ -> + false -> [] end. -opt(Op, [{Op, Value}|_]) -> - {ok, Value}; -opt(Op, [_|Options]) -> - opt(Op, Options); -opt(_, []) -> - false. - -debug_options(Opts) -> - case opt(debug, Opts) of - {ok, Options} -> sys:debug_options(Options); - _ -> [] +hibernate_after(Options) -> + case lists:keyfind(hibernate_after, 1, Options) of + {_,HibernateAfterTimeout} -> + HibernateAfterTimeout; + false -> + infinity + end. + +debug_options(Name, Opts) -> + case lists:keyfind(debug, 1, Opts) of + {_,Options} -> + try sys:debug_options(Options) + catch _:_ -> + error_logger:format( + "~tp: ignoring erroneous debug options - ~tp~n", + [Name,Options]), + [] + end; + false -> + [] end. format_status_header(TagLine, Pid) when is_pid(Pid) -> diff --git a/lib/stdlib/src/gen_event.erl b/lib/stdlib/src/gen_event.erl index 3d63c19de7..73e4457bd0 100644 --- a/lib/stdlib/src/gen_event.erl +++ b/lib/stdlib/src/gen_event.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2014. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -32,10 +32,12 @@ %%% Modified by Martin - uses proc_lib, sys and gen! --export([start/0, start/1, start_link/0, start_link/1, stop/1, stop/3, +-export([start/0, start/1, start/2, + start_link/0, start_link/1, start_link/2, + stop/1, stop/3, notify/2, sync_notify/2, add_handler/3, add_sup_handler/3, delete_handler/3, swap_handler/3, - swap_sup_handler/3, which_handlers/1, call/3, call/4, wake_hib/4]). + swap_sup_handler/3, which_handlers/1, call/3, call/4, wake_hib/5]). -export([init_it/6, system_continue/3, @@ -107,7 +109,8 @@ State :: term(), Status :: term(). --optional_callbacks([format_status/2]). +-optional_callbacks( + [handle_info/2, terminate/2, code_change/3, format_status/2]). %%--------------------------------------------------------------------------- @@ -117,45 +120,76 @@ -type del_handler_ret() :: ok | term() | {'EXIT',term()}. -type emgr_name() :: {'local', atom()} | {'global', atom()} - | {'via', atom(), term()}. + | {'via', atom(), term()}. +-type debug_flag() :: 'trace' | 'log' | 'statistics' | 'debug' + | {'logfile', string()}. +-type option() :: {'timeout', timeout()} + | {'debug', [debug_flag()]} + | {'spawn_opt', [proc_lib:spawn_option()]} + | {'hibernate_after', timeout()}. -type emgr_ref() :: atom() | {atom(), atom()} | {'global', atom()} - | {'via', atom(), term()} | pid(). + | {'via', atom(), term()} | pid(). -type start_ret() :: {'ok', pid()} | {'error', term()}. %%--------------------------------------------------------------------------- -define(NO_CALLBACK, 'no callback module'). +%% ----------------------------------------------------------------- +%% Starts a generic event handler. +%% start() +%% start(MgrName | Options) +%% start(MgrName, Options) +%% start_link() +%% start_link(MgrName | Options) +%% start_link(MgrName, Options) +%% MgrName ::= {local, atom()} | {global, atom()} | {via, atom(), term()} +%% Options ::= [{timeout, Timeout} | {debug, [Flag]} | {spawn_opt,SOpts}] +%% Flag ::= trace | log | {logfile, File} | statistics | debug +%% (debug == log && statistics) +%% Returns: {ok, Pid} | +%% {error, {already_started, Pid}} | +%% {error, Reason} +%% ----------------------------------------------------------------- + -spec start() -> start_ret(). start() -> gen:start(?MODULE, nolink, ?NO_CALLBACK, [], []). --spec start(emgr_name()) -> start_ret(). -start(Name) -> - gen:start(?MODULE, nolink, Name, ?NO_CALLBACK, [], []). +-spec start(emgr_name() | [option()]) -> start_ret(). +start(Name) when is_tuple(Name) -> + gen:start(?MODULE, nolink, Name, ?NO_CALLBACK, [], []); +start(Options) when is_list(Options) -> + gen:start(?MODULE, nolink, ?NO_CALLBACK, [], Options). + +-spec start(emgr_name(), [option()]) -> start_ret(). +start(Name, Options) -> + gen:start(?MODULE, nolink, Name, ?NO_CALLBACK, [], Options). -spec start_link() -> start_ret(). start_link() -> gen:start(?MODULE, link, ?NO_CALLBACK, [], []). --spec start_link(emgr_name()) -> start_ret(). -start_link(Name) -> - gen:start(?MODULE, link, Name, ?NO_CALLBACK, [], []). +-spec start_link(emgr_name() | [option()]) -> start_ret(). +start_link(Name) when is_tuple(Name) -> + gen:start(?MODULE, link, Name, ?NO_CALLBACK, [], []); +start_link(Options) when is_list(Options) -> + gen:start(?MODULE, link, ?NO_CALLBACK, [], Options). + +-spec start_link(emgr_name(), [option()]) -> start_ret(). +start_link(Name, Options) -> + gen:start(?MODULE, link, Name, ?NO_CALLBACK, [], Options). %% -spec init_it(pid(), 'self' | pid(), emgr_name(), module(), [term()], [_]) -> init_it(Starter, self, Name, Mod, Args, Options) -> init_it(Starter, self(), Name, Mod, Args, Options); init_it(Starter, Parent, Name0, _, _, Options) -> process_flag(trap_exit, true), - Debug = gen:debug_options(Options), + Name = gen:name(Name0), + Debug = gen:debug_options(Name, Options), + HibernateAfterTimeout = gen:hibernate_after(Options), proc_lib:init_ack(Starter, {ok, self()}), - Name = name(Name0), - loop(Parent, Name, [], Debug, false). - -name({local,Name}) -> Name; -name({global,Name}) -> Name; -name({via,_, Name}) -> Name; -name(Pid) when is_pid(Pid) -> Pid. + loop(Parent, Name, [], HibernateAfterTimeout, Debug, false). -spec add_handler(emgr_ref(), handler(), term()) -> term(). add_handler(M, Handler, Args) -> rpc(M, {add_handler, Handler, Args}). @@ -165,7 +199,7 @@ add_sup_handler(M, Handler, Args) -> rpc(M, {add_sup_handler, Handler, Args, self()}). -spec notify(emgr_ref(), term()) -> 'ok'. -notify(M, Event) -> send(M, {notify, Event}). +notify(M, Event) -> send(M, {notify, Event}). -spec sync_notify(emgr_ref(), term()) -> 'ok'. sync_notify(M, Event) -> rpc(M, {sync_notify, Event}). @@ -198,7 +232,7 @@ stop(M) -> stop(M, Reason, Timeout) -> gen:stop(M, Reason, Timeout). -rpc(M, Cmd) -> +rpc(M, Cmd) -> {ok, Reply} = gen:call(M, self(), Cmd, infinity), Reply. @@ -232,81 +266,83 @@ send(M, Cmd) -> M ! Cmd, ok. -loop(Parent, ServerName, MSL, Debug, true) -> - proc_lib:hibernate(?MODULE, wake_hib, [Parent, ServerName, MSL, Debug]); -loop(Parent, ServerName, MSL, Debug, _) -> - fetch_msg(Parent, ServerName, MSL, Debug, false). +loop(Parent, ServerName, MSL, HibernateAfterTimeout, Debug, true) -> + proc_lib:hibernate(?MODULE, wake_hib, [Parent, ServerName, MSL, HibernateAfterTimeout, Debug]); +loop(Parent, ServerName, MSL, HibernateAfterTimeout, Debug, _) -> + fetch_msg(Parent, ServerName, MSL, HibernateAfterTimeout, Debug, false). -wake_hib(Parent, ServerName, MSL, Debug) -> - fetch_msg(Parent, ServerName, MSL, Debug, true). +wake_hib(Parent, ServerName, MSL, HibernateAfterTimeout, Debug) -> + fetch_msg(Parent, ServerName, MSL, HibernateAfterTimeout, Debug, true). -fetch_msg(Parent, ServerName, MSL, Debug, Hib) -> +fetch_msg(Parent, ServerName, MSL, HibernateAfterTimeout, Debug, Hib) -> receive {system, From, Req} -> sys:handle_system_msg(Req, From, Parent, ?MODULE, Debug, - [ServerName, MSL, Hib],Hib); + [ServerName, MSL, HibernateAfterTimeout, Hib],Hib); {'EXIT', Parent, Reason} -> terminate_server(Reason, Parent, MSL, ServerName); Msg when Debug =:= [] -> - handle_msg(Msg, Parent, ServerName, MSL, []); + handle_msg(Msg, Parent, ServerName, MSL, HibernateAfterTimeout, []); Msg -> Debug1 = sys:handle_debug(Debug, fun print_event/3, ServerName, {in, Msg}), - handle_msg(Msg, Parent, ServerName, MSL, Debug1) + handle_msg(Msg, Parent, ServerName, MSL, HibernateAfterTimeout, Debug1) + after HibernateAfterTimeout -> + loop(Parent, ServerName, MSL, HibernateAfterTimeout, Debug, true) end. -handle_msg(Msg, Parent, ServerName, MSL, Debug) -> +handle_msg(Msg, Parent, ServerName, MSL, HibernateAfterTimeout, Debug) -> case Msg of {notify, Event} -> {Hib,MSL1} = server_notify(Event, handle_event, MSL, ServerName), - loop(Parent, ServerName, MSL1, Debug, Hib); + loop(Parent, ServerName, MSL1, HibernateAfterTimeout, Debug, Hib); {_From, Tag, {sync_notify, Event}} -> {Hib, MSL1} = server_notify(Event, handle_event, MSL, ServerName), reply(Tag, ok), - loop(Parent, ServerName, MSL1, Debug, Hib); + loop(Parent, ServerName, MSL1, HibernateAfterTimeout, Debug, Hib); {'EXIT', From, Reason} -> MSL1 = handle_exit(From, Reason, MSL, ServerName), - loop(Parent, ServerName, MSL1, Debug, false); + loop(Parent, ServerName, MSL1, HibernateAfterTimeout, Debug, false); {_From, Tag, {call, Handler, Query}} -> {Hib, Reply, MSL1} = server_call(Handler, Query, MSL, ServerName), reply(Tag, Reply), - loop(Parent, ServerName, MSL1, Debug, Hib); + loop(Parent, ServerName, MSL1, HibernateAfterTimeout, Debug, Hib); {_From, Tag, {add_handler, Handler, Args}} -> {Hib, Reply, MSL1} = server_add_handler(Handler, Args, MSL), reply(Tag, Reply), - loop(Parent, ServerName, MSL1, Debug, Hib); + loop(Parent, ServerName, MSL1, HibernateAfterTimeout, Debug, Hib); {_From, Tag, {add_sup_handler, Handler, Args, SupP}} -> {Hib, Reply, MSL1} = server_add_sup_handler(Handler, Args, MSL, SupP), reply(Tag, Reply), - loop(Parent, ServerName, MSL1, Debug, Hib); + loop(Parent, ServerName, MSL1, HibernateAfterTimeout, Debug, Hib); {_From, Tag, {delete_handler, Handler, Args}} -> {Reply, MSL1} = server_delete_handler(Handler, Args, MSL, ServerName), reply(Tag, Reply), - loop(Parent, ServerName, MSL1, Debug, false); + loop(Parent, ServerName, MSL1, HibernateAfterTimeout, Debug, false); {_From, Tag, {swap_handler, Handler1, Args1, Handler2, Args2}} -> {Hib, Reply, MSL1} = server_swap_handler(Handler1, Args1, Handler2, Args2, MSL, ServerName), reply(Tag, Reply), - loop(Parent, ServerName, MSL1, Debug, Hib); + loop(Parent, ServerName, MSL1, HibernateAfterTimeout, Debug, Hib); {_From, Tag, {swap_sup_handler, Handler1, Args1, Handler2, Args2, Sup}} -> {Hib, Reply, MSL1} = server_swap_handler(Handler1, Args1, Handler2, Args2, MSL, Sup, ServerName), reply(Tag, Reply), - loop(Parent, ServerName, MSL1, Debug, Hib); + loop(Parent, ServerName, MSL1, HibernateAfterTimeout, Debug, Hib); {_From, Tag, stop} -> catch terminate_server(normal, Parent, MSL, ServerName), reply(Tag, ok); {_From, Tag, which_handlers} -> reply(Tag, the_handlers(MSL)), - loop(Parent, ServerName, MSL, Debug, false); + loop(Parent, ServerName, MSL, HibernateAfterTimeout, Debug, false); {_From, Tag, get_modules} -> reply(Tag, get_modules(MSL)), - loop(Parent, ServerName, MSL, Debug, false); + loop(Parent, ServerName, MSL, HibernateAfterTimeout, Debug, false); Other -> {Hib, MSL1} = server_notify(Other, handle_info, MSL, ServerName), - loop(Parent, ServerName, MSL1, Debug, Hib) + loop(Parent, ServerName, MSL1, HibernateAfterTimeout, Debug, Hib) end. terminate_server(Reason, Parent, MSL, ServerName) -> @@ -360,18 +396,18 @@ terminate_supervised(Pid, Reason, MSL, SName) -> %%----------------------------------------------------------------- %% Callback functions for system messages handling. %%----------------------------------------------------------------- -system_continue(Parent, Debug, [ServerName, MSL, Hib]) -> - loop(Parent, ServerName, MSL, Debug, Hib). +system_continue(Parent, Debug, [ServerName, MSL, HibernateAfterTimeout, Hib]) -> + loop(Parent, ServerName, MSL, HibernateAfterTimeout, Debug, Hib). -spec system_terminate(_, _, _, [_]) -> no_return(). -system_terminate(Reason, Parent, _Debug, [ServerName, MSL, _Hib]) -> +system_terminate(Reason, Parent, _Debug, [ServerName, MSL, _HibernateAfterTimeout, _Hib]) -> terminate_server(Reason, Parent, MSL, ServerName). %%----------------------------------------------------------------- %% Module here is sent in the system msg change_code. It specifies %% which module should be changed. %%----------------------------------------------------------------- -system_code_change([ServerName, MSL, Hib], Module, OldVsn, Extra) -> +system_code_change([ServerName, MSL, HibernateAfterTimeout, Hib], Module, OldVsn, Extra) -> MSL1 = lists:zf(fun(H) when H#handler.module =:= Module -> {ok, NewState} = Module:code_change(OldVsn, @@ -380,12 +416,12 @@ system_code_change([ServerName, MSL, Hib], Module, OldVsn, Extra) -> (_) -> true end, MSL), - {ok, [ServerName, MSL1, Hib]}. + {ok, [ServerName, MSL1, HibernateAfterTimeout, Hib]}. -system_get_state([_ServerName, MSL, _Hib]) -> +system_get_state([_ServerName, MSL, _HibernateAfterTimeout, _Hib]) -> {ok, [{Mod,Id,State} || #handler{module=Mod, id=Id, state=State} <- MSL]}. -system_replace_state(StateFun, [ServerName, MSL, Hib]) -> +system_replace_state(StateFun, [ServerName, MSL, HibernateAfterTimeout, Hib]) -> {NMSL, NStates} = lists:unzip([begin Cur = {Mod,Id,State}, @@ -397,7 +433,7 @@ system_replace_state(StateFun, [ServerName, MSL, Hib]) -> {HS, Cur} end end || #handler{module=Mod, id=Id, state=State}=HS <- MSL]), - {ok, NStates, [ServerName, NMSL, Hib]}. + {ok, NStates, [ServerName, NMSL, HibernateAfterTimeout, Hib]}. %%----------------------------------------------------------------- %% Format debug messages. Print them as the call-back module sees @@ -406,15 +442,15 @@ system_replace_state(StateFun, [ServerName, MSL, Hib]) -> print_event(Dev, {in, Msg}, Name) -> case Msg of {notify, Event} -> - io:format(Dev, "*DBG* ~p got event ~p~n", [Name, Event]); + io:format(Dev, "*DBG* ~tp got event ~tp~n", [Name, Event]); {_,_,{call, Handler, Query}} -> - io:format(Dev, "*DBG* ~p(~p) got call ~p~n", + io:format(Dev, "*DBG* ~tp(~tp) got call ~tp~n", [Name, Handler, Query]); _ -> - io:format(Dev, "*DBG* ~p got ~p~n", [Name, Msg]) + io:format(Dev, "*DBG* ~tp got ~tp~n", [Name, Msg]) end; print_event(Dev, Dbg, Name) -> - io:format(Dev, "*DBG* ~p : ~p~n", [Name, Dbg]). + io:format(Dev, "*DBG* ~tp : ~tp~n", [Name, Dbg]). %% server_add_handler(Handler, Args, MSL) -> {Ret, MSL'}. @@ -426,7 +462,7 @@ server_add_handler({Mod,Id}, Args, MSL) -> Handler = #handler{module = Mod, id = Id}, server_add_handler(Mod, Handler, Args, MSL); -server_add_handler(Mod, Args, MSL) -> +server_add_handler(Mod, Args, MSL) -> Handler = #handler{module = Mod}, server_add_handler(Mod, Handler, Args, MSL). @@ -451,7 +487,7 @@ server_add_sup_handler({Mod,Id}, Args, MSL, Parent) -> id = Id, supervised = Parent}, server_add_handler(Mod, Handler, Args, MSL); -server_add_sup_handler(Mod, Args, MSL, Parent) -> +server_add_sup_handler(Mod, Args, MSL, Parent) -> link(Parent), Handler = #handler{module = Mod, supervised = Parent}, @@ -459,7 +495,7 @@ server_add_sup_handler(Mod, Args, MSL, Parent) -> %% server_delete_handler(HandlerId, Args, MSL) -> {Ret, MSL'} -server_delete_handler(HandlerId, Args, MSL, SName) -> +server_delete_handler(HandlerId, Args, MSL, SName) -> case split(HandlerId, MSL) of {Mod, Handler, MSL1} -> {do_terminate(Mod, Handler, Args, @@ -516,7 +552,7 @@ split_and_terminate(HandlerId, Args, MSL, SName, Handler2, Sup) -> %% server_notify(Event, Func, MSL, SName) -> MSL' -server_notify(Event, Func, [Handler|T], SName) -> +server_notify(Event, Func, [Handler|T], SName) -> case server_update(Handler, Func, Event, SName) of {ok, Handler1} -> {Hib, NewHandlers} = server_notify(Event, Func, T, SName), @@ -536,9 +572,9 @@ server_update(Handler1, Func, Event, SName) -> Mod1 = Handler1#handler.module, State = Handler1#handler.state, case catch Mod1:Func(Event, State) of - {ok, State1} -> + {ok, State1} -> {ok, Handler1#handler{state = State1}}; - {ok, State1, hibernate} -> + {ok, State1, hibernate} -> {hibernate, Handler1#handler{state = State1}}; {swap_handler, Args1, State1, Handler2, Args2} -> do_swap(Mod1, Handler1, Args1, State1, Handler2, Args2, SName); @@ -546,6 +582,10 @@ server_update(Handler1, Func, Event, SName) -> do_terminate(Mod1, Handler1, remove_handler, State, remove, SName, normal), no; + {'EXIT', {undef, [{Mod1, handle_info, [_,_], _}|_]}} -> + error_logger:warning_msg("** Undefined handle_info in ~tp~n" + "** Unhandled message: ~tp~n", [Mod1, Event]), + {ok, Handler1}; Other -> do_terminate(Mod1, Handler1, {error, Other}, State, Event, SName, crash), @@ -649,14 +689,14 @@ server_call_update(Handler1, Query, SName) -> Mod1 = Handler1#handler.module, State = Handler1#handler.state, case catch Mod1:handle_call(Query, State) of - {ok, Reply, State1} -> + {ok, Reply, State1} -> {{ok, Handler1#handler{state = State1}}, Reply}; - {ok, Reply, State1, hibernate} -> - {{hibernate, Handler1#handler{state = State1}}, + {ok, Reply, State1, hibernate} -> + {{hibernate, Handler1#handler{state = State1}}, Reply}; {swap_handler, Reply, Args1, State1, Handler2, Args2} -> {do_swap(Mod1,Handler1,Args1,State1,Handler2,Args2,SName), Reply}; - {remove_handler, Reply} -> + {remove_handler, Reply} -> do_terminate(Mod1, Handler1, remove_handler, State, remove, SName, normal), {no, Reply}; @@ -667,9 +707,15 @@ server_call_update(Handler1, Query, SName) -> end. do_terminate(Mod, Handler, Args, State, LastIn, SName, Reason) -> - Res = (catch Mod:terminate(Args, State)), - report_terminate(Handler, Reason, Args, State, LastIn, SName, Res), - Res. + case erlang:function_exported(Mod, terminate, 2) of + true -> + Res = (catch Mod:terminate(Args, State)), + report_terminate(Handler, Reason, Args, State, LastIn, SName, Res), + Res; + false -> + report_terminate(Handler, Reason, Args, State, LastIn, SName, ok), + ok + end. report_terminate(Handler, crash, {error, Why}, State, LastIn, SName, _) -> report_terminate(Handler, Why, State, LastIn, SName); @@ -691,7 +737,7 @@ report_error(_Handler, normal, _, _, _) -> ok; report_error(_Handler, shutdown, _, _, _) -> ok; report_error(_Handler, {swapped,_,_}, _, _, _) -> ok; report_error(Handler, Reason, State, LastIn, SName) -> - Reason1 = + Reason1 = case Reason of {'EXIT',{undef,[{M,F,A,L}|MFAs]}} -> case code:is_loaded(M) of @@ -722,10 +768,10 @@ report_error(Handler, Reason, State, LastIn, SName) -> State end, error_msg("** gen_event handler ~p crashed.~n" - "** Was installed in ~p~n" - "** Last event was: ~p~n" - "** When handler state == ~p~n" - "** Reason == ~p~n", + "** Was installed in ~tp~n" + "** Last event was: ~tp~n" + "** When handler state == ~tp~n" + "** Reason == ~tp~n", [handler(Handler),SName,LastIn,FmtState,Reason1]). handler(Handler) when not Handler#handler.id -> @@ -747,7 +793,7 @@ stop_handlers([], _) -> []. %% Message from the release_handler. -%% The list of modules got to be a set ! +%% The list of modules got to be a set, i.e. no duplicate elements! get_modules(MSL) -> Mods = [Handler#handler.module || Handler <- MSL], ordsets:to_list(ordsets:from_list(Mods)). @@ -756,7 +802,7 @@ get_modules(MSL) -> %% Status information %%----------------------------------------------------------------- format_status(Opt, StatusData) -> - [PDict, SysState, Parent, _Debug, [ServerName, MSL, _Hib]] = StatusData, + [PDict, SysState, Parent, _Debug, [ServerName, MSL, _HibernateAfterTimeout, _Hib]] = StatusData, Header = gen:format_status_header("Status for event handler", ServerName), FmtMSL = [case erlang:function_exported(Mod, format_status, 2) of diff --git a/lib/stdlib/src/gen_fsm.erl b/lib/stdlib/src/gen_fsm.erl index 7eabb95548..8c7db65563 100644 --- a/lib/stdlib/src/gen_fsm.erl +++ b/lib/stdlib/src/gen_fsm.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2014. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -113,7 +113,7 @@ sync_send_all_state_event/2, sync_send_all_state_event/3, reply/2, start_timer/2,send_event_after/2,cancel_timer/1, - enter_loop/4, enter_loop/5, enter_loop/6, wake_hib/6]). + enter_loop/4, enter_loop/5, enter_loop/6, wake_hib/7]). %% Internal exports -export([init_it/6, @@ -124,6 +124,26 @@ system_replace_state/2, format_status/2]). +-deprecated({start, 3, next_major_release}). +-deprecated({start, 4, next_major_release}). +-deprecated({start_link, 3, next_major_release}). +-deprecated({start_link, 4, next_major_release}). +-deprecated({stop, 1, next_major_release}). +-deprecated({stop, 3, next_major_release}). +-deprecated({send_event, 2, next_major_release}). +-deprecated({sync_send_event, 2, next_major_release}). +-deprecated({sync_send_event, 3, next_major_release}). +-deprecated({send_all_state_event, 2, next_major_release}). +-deprecated({sync_send_all_state_event, 2, next_major_release}). +-deprecated({sync_send_all_state_event, 3, next_major_release}). +-deprecated({reply, 2, next_major_release}). +-deprecated({start_timer, 2, next_major_release}). +-deprecated({send_event_after, 2, next_major_release}). +-deprecated({cancel_timer, 1, next_major_release}). +-deprecated({enter_loop, 4, next_major_release}). +-deprecated({enter_loop, 5, next_major_release}). +-deprecated({enter_loop, 6, next_major_release}). + -import(error_logger, [format/2]). %%% --------------------------------------------------- @@ -169,7 +189,8 @@ State :: term(), Status :: term(). --optional_callbacks([format_status/2]). +-optional_callbacks( + [handle_info/3, terminate/3, code_change/4, format_status/2]). %%% --------------------------------------------------- %%% Starts a generic state machine. @@ -177,7 +198,7 @@ %%% start(Name, Mod, Args, Options) %%% start_link(Mod, Args, Options) %%% start_link(Name, Mod, Args, Options) where: -%%% Name ::= {local, atom()} | {global, atom()} | {via, atom(), term()} +%%% Name ::= {local, atom()} | {global, term()} | {via, atom(), term()} %%% Mod ::= atom(), callback module implementing the 'real' fsm %%% Args ::= term(), init arguments (to Mod:init/1) %%% Options ::= [{debug, [Flag]}] @@ -273,7 +294,7 @@ start_timer(Time, Msg) -> send_event_after(Time, Event) -> erlang:start_timer(Time, self(), {'$gen_event', Event}). -%% Returns the remaing time for the timer if Ref referred to +%% Returns the remaining time for the timer if Ref referred to %% an active timer/send_event_after, false otherwise. cancel_timer(Ref) -> case erlang:cancel_timer(Ref) of @@ -305,63 +326,11 @@ enter_loop(Mod, Options, StateName, StateData, Timeout) -> enter_loop(Mod, Options, StateName, StateData, self(), Timeout). enter_loop(Mod, Options, StateName, StateData, ServerName, Timeout) -> - Name = get_proc_name(ServerName), - Parent = get_parent(), - Debug = gen:debug_options(Options), - loop(Parent, Name, StateName, StateData, Mod, Timeout, Debug). - -get_proc_name(Pid) when is_pid(Pid) -> - Pid; -get_proc_name({local, Name}) -> - case process_info(self(), registered_name) of - {registered_name, Name} -> - Name; - {registered_name, _Name} -> - exit(process_not_registered); - [] -> - exit(process_not_registered) - end; -get_proc_name({global, Name}) -> - case global:whereis_name(Name) of - undefined -> - exit(process_not_registered_globally); - Pid when Pid =:= self() -> - Name; - _Pid -> - exit(process_not_registered_globally) - end; -get_proc_name({via, Mod, Name}) -> - case Mod:whereis_name(Name) of - undefined -> - exit({process_not_registered_via, Mod}); - Pid when Pid =:= self() -> - Name; - _Pid -> - exit({process_not_registered_via, Mod}) - end. - -get_parent() -> - case get('$ancestors') of - [Parent | _] when is_pid(Parent) -> - Parent; - [Parent | _] when is_atom(Parent) -> - name_to_pid(Parent); - _ -> - exit(process_was_not_started_by_proc_lib) - end. - -name_to_pid(Name) -> - case whereis(Name) of - undefined -> - case global:whereis_name(Name) of - undefined -> - exit(could_not_find_registered_name); - Pid -> - Pid - end; - Pid -> - Pid - end. + Name = gen:get_proc_name(ServerName), + Parent = gen:get_parent(), + Debug = gen:debug_options(Name, Options), + HibernateAfterTimeout = gen:hibernate_after(Options), + loop(Parent, Name, StateName, StateData, Mod, Timeout, HibernateAfterTimeout, Debug). %%% --------------------------------------------------- %%% Initiate the new process. @@ -373,25 +342,26 @@ name_to_pid(Name) -> init_it(Starter, self, Name, Mod, Args, Options) -> init_it(Starter, self(), Name, Mod, Args, Options); init_it(Starter, Parent, Name0, Mod, Args, Options) -> - Name = name(Name0), - Debug = gen:debug_options(Options), - case catch Mod:init(Args) of + Name = gen:name(Name0), + Debug = gen:debug_options(Name, Options), + HibernateAfterTimeout = gen:hibernate_after(Options), + case catch Mod:init(Args) of {ok, StateName, StateData} -> proc_lib:init_ack(Starter, {ok, self()}), - loop(Parent, Name, StateName, StateData, Mod, infinity, Debug); + loop(Parent, Name, StateName, StateData, Mod, infinity, HibernateAfterTimeout, Debug); {ok, StateName, StateData, Timeout} -> proc_lib:init_ack(Starter, {ok, self()}), - loop(Parent, Name, StateName, StateData, Mod, Timeout, Debug); + loop(Parent, Name, StateName, StateData, Mod, Timeout, HibernateAfterTimeout, Debug); {stop, Reason} -> - unregister_name(Name0), + gen:unregister_name(Name0), proc_lib:init_ack(Starter, {error, Reason}), exit(Reason); ignore -> - unregister_name(Name0), + gen:unregister_name(Name0), proc_lib:init_ack(Starter, ignore), exit(normal); {'EXIT', Reason} -> - unregister_name(Name0), + gen:unregister_name(Name0), proc_lib:init_ack(Starter, {error, Reason}), exit(Reason); Else -> @@ -400,85 +370,80 @@ init_it(Starter, Parent, Name0, Mod, Args, Options) -> exit(Error) end. -name({local,Name}) -> Name; -name({global,Name}) -> Name; -name({via,_, Name}) -> Name; -name(Pid) when is_pid(Pid) -> Pid. - -unregister_name({local,Name}) -> - _ = (catch unregister(Name)); -unregister_name({global,Name}) -> - _ = global:unregister_name(Name); -unregister_name({via, Mod, Name}) -> - _ = Mod:unregister_name(Name); -unregister_name(Pid) when is_pid(Pid) -> - Pid. - %%----------------------------------------------------------------- %% The MAIN loop %%----------------------------------------------------------------- -loop(Parent, Name, StateName, StateData, Mod, hibernate, Debug) -> +loop(Parent, Name, StateName, StateData, Mod, hibernate, HibernateAfterTimeout, Debug) -> proc_lib:hibernate(?MODULE,wake_hib, - [Parent, Name, StateName, StateData, Mod, + [Parent, Name, StateName, StateData, Mod, HibernateAfterTimeout, Debug]); -loop(Parent, Name, StateName, StateData, Mod, Time, Debug) -> + +loop(Parent, Name, StateName, StateData, Mod, infinity, HibernateAfterTimeout, Debug) -> + receive + Msg -> + decode_msg(Msg,Parent, Name, StateName, StateData, Mod, infinity, HibernateAfterTimeout, Debug, false) + after HibernateAfterTimeout -> + loop(Parent, Name, StateName, StateData, Mod, hibernate, HibernateAfterTimeout, Debug) + end; + +loop(Parent, Name, StateName, StateData, Mod, Time, HibernateAfterTimeout, Debug) -> Msg = receive Input -> Input after Time -> {'$gen_event', timeout} end, - decode_msg(Msg,Parent, Name, StateName, StateData, Mod, Time, Debug, false). + decode_msg(Msg,Parent, Name, StateName, StateData, Mod, Time, HibernateAfterTimeout, Debug, false). -wake_hib(Parent, Name, StateName, StateData, Mod, Debug) -> +wake_hib(Parent, Name, StateName, StateData, Mod, HibernateAfterTimeout, Debug) -> Msg = receive Input -> Input end, - decode_msg(Msg, Parent, Name, StateName, StateData, Mod, hibernate, Debug, true). + decode_msg(Msg, Parent, Name, StateName, StateData, Mod, hibernate, HibernateAfterTimeout, Debug, true). -decode_msg(Msg,Parent, Name, StateName, StateData, Mod, Time, Debug, Hib) -> +decode_msg(Msg,Parent, Name, StateName, StateData, Mod, Time, HibernateAfterTimeout, Debug, Hib) -> case Msg of {system, From, Req} -> sys:handle_system_msg(Req, From, Parent, ?MODULE, Debug, - [Name, StateName, StateData, Mod, Time], Hib); + [Name, StateName, StateData, Mod, Time, HibernateAfterTimeout], Hib); {'EXIT', Parent, Reason} -> terminate(Reason, Name, Msg, Mod, StateName, StateData, Debug); _Msg when Debug =:= [] -> - handle_msg(Msg, Parent, Name, StateName, StateData, Mod, Time); + handle_msg(Msg, Parent, Name, StateName, StateData, Mod, Time, HibernateAfterTimeout); _Msg -> Debug1 = sys:handle_debug(Debug, fun print_event/3, {Name, StateName}, {in, Msg}), handle_msg(Msg, Parent, Name, StateName, StateData, - Mod, Time, Debug1) + Mod, Time, HibernateAfterTimeout, Debug1) end. %%----------------------------------------------------------------- %% Callback functions for system messages handling. %%----------------------------------------------------------------- -system_continue(Parent, Debug, [Name, StateName, StateData, Mod, Time]) -> - loop(Parent, Name, StateName, StateData, Mod, Time, Debug). +system_continue(Parent, Debug, [Name, StateName, StateData, Mod, Time, HibernateAfterTimeout]) -> + loop(Parent, Name, StateName, StateData, Mod, Time, HibernateAfterTimeout, Debug). -spec system_terminate(term(), _, _, [term(),...]) -> no_return(). system_terminate(Reason, _Parent, Debug, - [Name, StateName, StateData, Mod, _Time]) -> + [Name, StateName, StateData, Mod, _Time, _HibernateAfterTimeout]) -> terminate(Reason, Name, [], Mod, StateName, StateData, Debug). -system_code_change([Name, StateName, StateData, Mod, Time], +system_code_change([Name, StateName, StateData, Mod, Time, HibernateAfterTimeout], _Module, OldVsn, Extra) -> case catch Mod:code_change(OldVsn, StateName, StateData, Extra) of {ok, NewStateName, NewStateData} -> - {ok, [Name, NewStateName, NewStateData, Mod, Time]}; + {ok, [Name, NewStateName, NewStateData, Mod, Time, HibernateAfterTimeout]}; Else -> Else end. -system_get_state([_Name, StateName, StateData, _Mod, _Time]) -> +system_get_state([_Name, StateName, StateData, _Mod, _Time, _HibernateAfterTimeout]) -> {ok, {StateName, StateData}}. -system_replace_state(StateFun, [Name, StateName, StateData, Mod, Time]) -> +system_replace_state(StateFun, [Name, StateName, StateData, Mod, Time, HibernateAfterTimeout]) -> Result = {NStateName, NStateData} = StateFun({StateName, StateData}), - {ok, Result, [Name, NStateName, NStateData, Mod, Time]}. + {ok, Result, [Name, NStateName, NStateData, Mod, Time, HibernateAfterTimeout]}. %%----------------------------------------------------------------- %% Format debug messages. Print them as the call-back module sees @@ -487,45 +452,45 @@ system_replace_state(StateFun, [Name, StateName, StateData, Mod, Time]) -> print_event(Dev, {in, Msg}, {Name, StateName}) -> case Msg of {'$gen_event', Event} -> - io:format(Dev, "*DBG* ~p got event ~p in state ~w~n", + io:format(Dev, "*DBG* ~tp got event ~tp in state ~tw~n", [Name, Event, StateName]); {'$gen_all_state_event', Event} -> io:format(Dev, - "*DBG* ~p got all_state_event ~p in state ~w~n", + "*DBG* ~tp got all_state_event ~tp in state ~tw~n", [Name, Event, StateName]); {timeout, Ref, {'$gen_timer', Message}} -> io:format(Dev, - "*DBG* ~p got timer ~p in state ~w~n", + "*DBG* ~tp got timer ~tp in state ~tw~n", [Name, {timeout, Ref, Message}, StateName]); {timeout, _Ref, {'$gen_event', Event}} -> io:format(Dev, - "*DBG* ~p got timer ~p in state ~w~n", + "*DBG* ~tp got timer ~tp in state ~tw~n", [Name, Event, StateName]); _ -> - io:format(Dev, "*DBG* ~p got ~p in state ~w~n", + io:format(Dev, "*DBG* ~tp got ~tp in state ~tw~n", [Name, Msg, StateName]) end; print_event(Dev, {out, Msg, To, StateName}, Name) -> - io:format(Dev, "*DBG* ~p sent ~p to ~w~n" - " and switched to state ~w~n", + io:format(Dev, "*DBG* ~tp sent ~tp to ~tw~n" + " and switched to state ~tw~n", [Name, Msg, To, StateName]); print_event(Dev, return, {Name, StateName}) -> - io:format(Dev, "*DBG* ~p switched to state ~w~n", + io:format(Dev, "*DBG* ~tp switched to state ~tw~n", [Name, StateName]). -handle_msg(Msg, Parent, Name, StateName, StateData, Mod, _Time) -> %No debug here +handle_msg(Msg, Parent, Name, StateName, StateData, Mod, _Time, HibernateAfterTimeout) -> %No debug here From = from(Msg), case catch dispatch(Msg, Mod, StateName, StateData) of {next_state, NStateName, NStateData} -> - loop(Parent, Name, NStateName, NStateData, Mod, infinity, []); + loop(Parent, Name, NStateName, NStateData, Mod, infinity, HibernateAfterTimeout, []); {next_state, NStateName, NStateData, Time1} -> - loop(Parent, Name, NStateName, NStateData, Mod, Time1, []); + loop(Parent, Name, NStateName, NStateData, Mod, Time1, HibernateAfterTimeout, []); {reply, Reply, NStateName, NStateData} when From =/= undefined -> reply(From, Reply), - loop(Parent, Name, NStateName, NStateData, Mod, infinity, []); + loop(Parent, Name, NStateName, NStateData, Mod, infinity, HibernateAfterTimeout, []); {reply, Reply, NStateName, NStateData, Time1} when From =/= undefined -> reply(From, Reply), - loop(Parent, Name, NStateName, NStateData, Mod, Time1, []); + loop(Parent, Name, NStateName, NStateData, Mod, Time1, HibernateAfterTimeout, []); {stop, Reason, NStateData} -> terminate(Reason, Name, Msg, Mod, StateName, NStateData, []); {stop, Reason, Reply, NStateData} when From =/= undefined -> @@ -533,6 +498,10 @@ handle_msg(Msg, Parent, Name, StateName, StateData, Mod, _Time) -> %No debug her StateName, NStateData, [])), reply(From, Reply), exit(R); + {'EXIT', {undef, [{Mod, handle_info, [_,_,_], _}|_]}} -> + error_logger:warning_msg("** Undefined handle_info in ~p~n" + "** Unhandled message: ~tp~n", [Mod, Msg]), + loop(Parent, Name, StateName, StateData, Mod, infinity, HibernateAfterTimeout, []); {'EXIT', What} -> terminate(What, Name, Msg, Mod, StateName, StateData, []); Reply -> @@ -540,23 +509,23 @@ handle_msg(Msg, Parent, Name, StateName, StateData, Mod, _Time) -> %No debug her Name, Msg, Mod, StateName, StateData, []) end. -handle_msg(Msg, Parent, Name, StateName, StateData, Mod, _Time, Debug) -> +handle_msg(Msg, Parent, Name, StateName, StateData, Mod, _Time, HibernateAfterTimeout, Debug) -> From = from(Msg), case catch dispatch(Msg, Mod, StateName, StateData) of {next_state, NStateName, NStateData} -> Debug1 = sys:handle_debug(Debug, fun print_event/3, {Name, NStateName}, return), - loop(Parent, Name, NStateName, NStateData, Mod, infinity, Debug1); + loop(Parent, Name, NStateName, NStateData, Mod, infinity, HibernateAfterTimeout, Debug1); {next_state, NStateName, NStateData, Time1} -> Debug1 = sys:handle_debug(Debug, fun print_event/3, {Name, NStateName}, return), - loop(Parent, Name, NStateName, NStateData, Mod, Time1, Debug1); + loop(Parent, Name, NStateName, NStateData, Mod, Time1, HibernateAfterTimeout, Debug1); {reply, Reply, NStateName, NStateData} when From =/= undefined -> Debug1 = reply(Name, From, Reply, Debug, NStateName), - loop(Parent, Name, NStateName, NStateData, Mod, infinity, Debug1); + loop(Parent, Name, NStateName, NStateData, Mod, infinity, HibernateAfterTimeout, Debug1); {reply, Reply, NStateName, NStateData, Time1} when From =/= undefined -> Debug1 = reply(Name, From, Reply, Debug, NStateName), - loop(Parent, Name, NStateName, NStateData, Mod, Time1, Debug1); + loop(Parent, Name, NStateName, NStateData, Mod, Time1, HibernateAfterTimeout, Debug1); {stop, Reason, NStateData} -> terminate(Reason, Name, Msg, Mod, StateName, NStateData, Debug); {stop, Reason, Reply, NStateData} when From =/= undefined -> @@ -607,24 +576,30 @@ reply(Name, {To, Tag}, Reply, Debug, StateName) -> -spec terminate(term(), _, _, atom(), _, _, _) -> no_return(). terminate(Reason, Name, Msg, Mod, StateName, StateData, Debug) -> - case catch Mod:terminate(Reason, StateName, StateData) of - {'EXIT', R} -> - FmtStateData = format_status(terminate, Mod, get(), StateData), - error_info(R, Name, Msg, StateName, FmtStateData, Debug), - exit(R); - _ -> - case Reason of - normal -> - exit(normal); - shutdown -> - exit(shutdown); - {shutdown,_}=Shutdown -> - exit(Shutdown); + case erlang:function_exported(Mod, terminate, 3) of + true -> + case catch Mod:terminate(Reason, StateName, StateData) of + {'EXIT', R} -> + FmtStateData = format_status(terminate, Mod, get(), StateData), + error_info(R, Name, Msg, StateName, FmtStateData, Debug), + exit(R); _ -> - FmtStateData = format_status(terminate, Mod, get(), StateData), - error_info(Reason,Name,Msg,StateName,FmtStateData,Debug), - exit(Reason) - end + ok + end; + false -> + ok + end, + case Reason of + normal -> + exit(normal); + shutdown -> + exit(shutdown); + {shutdown,_}=Shutdown -> + exit(Shutdown); + _ -> + FmtStateData1 = format_status(terminate, Mod, get(), StateData), + error_info(Reason,Name,Msg,StateName,FmtStateData1,Debug), + exit(Reason) end. error_info(Reason, Name, Msg, StateName, StateData, Debug) -> @@ -645,29 +620,29 @@ error_info(Reason, Name, Msg, StateName, StateData, Debug) -> _ -> Reason end, - Str = "** State machine ~p terminating \n" ++ + Str = "** State machine ~tp terminating \n" ++ get_msg_str(Msg) ++ - "** When State == ~p~n" - "** Data == ~p~n" - "** Reason for termination = ~n** ~p~n", + "** When State == ~tp~n" + "** Data == ~tp~n" + "** Reason for termination = ~n** ~tp~n", format(Str, [Name, get_msg(Msg), StateName, StateData, Reason1]), sys:print_log(Debug), ok. get_msg_str({'$gen_event', _Event}) -> - "** Last event in was ~p~n"; + "** Last event in was ~tp~n"; get_msg_str({'$gen_sync_event', _Event}) -> - "** Last sync event in was ~p~n"; + "** Last sync event in was ~tp~n"; get_msg_str({'$gen_all_state_event', _Event}) -> - "** Last event in was ~p (for all states)~n"; + "** Last event in was ~tp (for all states)~n"; get_msg_str({'$gen_sync_all_state_event', _Event}) -> - "** Last sync event in was ~p (for all states)~n"; + "** Last sync event in was ~tp (for all states)~n"; get_msg_str({timeout, _Ref, {'$gen_timer', _Msg}}) -> - "** Last timer event in was ~p~n"; + "** Last timer event in was ~tp~n"; get_msg_str({timeout, _Ref, {'$gen_event', _Msg}}) -> - "** Last timer event in was ~p~n"; + "** Last timer event in was ~tp~n"; get_msg_str(_Msg) -> - "** Last message in was ~p~n". + "** Last message in was ~tp~n". get_msg({'$gen_event', Event}) -> Event; get_msg({'$gen_sync_event', Event}) -> Event; @@ -681,7 +656,7 @@ get_msg(Msg) -> Msg. %% Status information %%----------------------------------------------------------------- format_status(Opt, StatusData) -> - [PDict, SysState, Parent, Debug, [Name, StateName, StateData, Mod, _Time]] = + [PDict, SysState, Parent, Debug, [Name, StateName, StateData, Mod, _Time, _HibernateAfterTimeout]] = StatusData, Header = gen:format_status_header("Status for state machine", Name), diff --git a/lib/stdlib/src/gen_server.erl b/lib/stdlib/src/gen_server.erl index c58b1de609..7daa7a9fe4 100644 --- a/lib/stdlib/src/gen_server.erl +++ b/lib/stdlib/src/gen_server.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2014. All Rights Reserved. +%% Copyright Ericsson AB 1996-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -94,7 +94,7 @@ cast/2, reply/2, abcast/2, abcast/3, multi_call/2, multi_call/3, multi_call/4, - enter_loop/3, enter_loop/4, enter_loop/5, wake_hib/5]). + enter_loop/3, enter_loop/4, enter_loop/5, wake_hib/6]). %% System exports -export([system_continue/3, @@ -107,7 +107,9 @@ %% Internal exports -export([init_it/6]). --import(error_logger, [format/2]). +-define( + STACKTRACE(), + try throw(ok) catch _ -> erlang:get_stacktrace() end). %%%========================================================================= %%% API @@ -146,8 +148,8 @@ State :: term(), Status :: term(). --optional_callbacks([format_status/2]). - +-optional_callbacks( + [handle_info/2, terminate/2, code_change/3, format_status/2]). %%% ----------------------------------------------------------------- %%% Starts a generic server. @@ -304,10 +306,11 @@ enter_loop(Mod, Options, State, Timeout) -> enter_loop(Mod, Options, State, self(), Timeout). enter_loop(Mod, Options, State, ServerName, Timeout) -> - Name = get_proc_name(ServerName), - Parent = get_parent(), - Debug = debug_options(Name, Options), - loop(Parent, Name, State, Mod, Timeout, Debug). + Name = gen:get_proc_name(ServerName), + Parent = gen:get_parent(), + Debug = gen:debug_options(Name, Options), + HibernateAfterTimeout = gen:hibernate_after(Options), + loop(Parent, Name, State, Mod, Timeout, HibernateAfterTimeout, Debug). %%%======================================================================== %%% Gen-callback functions @@ -323,90 +326,94 @@ enter_loop(Mod, Options, State, ServerName, Timeout) -> init_it(Starter, self, Name, Mod, Args, Options) -> init_it(Starter, self(), Name, Mod, Args, Options); init_it(Starter, Parent, Name0, Mod, Args, Options) -> - Name = name(Name0), - Debug = debug_options(Name, Options), - case catch Mod:init(Args) of - {ok, State} -> + Name = gen:name(Name0), + Debug = gen:debug_options(Name, Options), + HibernateAfterTimeout = gen:hibernate_after(Options), + + case init_it(Mod, Args) of + {ok, {ok, State}} -> proc_lib:init_ack(Starter, {ok, self()}), - loop(Parent, Name, State, Mod, infinity, Debug); - {ok, State, Timeout} -> + loop(Parent, Name, State, Mod, infinity, HibernateAfterTimeout, Debug); + {ok, {ok, State, Timeout}} -> proc_lib:init_ack(Starter, {ok, self()}), - loop(Parent, Name, State, Mod, Timeout, Debug); - {stop, Reason} -> + loop(Parent, Name, State, Mod, Timeout, HibernateAfterTimeout, Debug); + {ok, {stop, Reason}} -> %% For consistency, we must make sure that the %% registered name (if any) is unregistered before %% the parent process is notified about the failure. %% (Otherwise, the parent process could get %% an 'already_started' error if it immediately %% tried starting the process again.) - unregister_name(Name0), + gen:unregister_name(Name0), proc_lib:init_ack(Starter, {error, Reason}), exit(Reason); - ignore -> - unregister_name(Name0), + {ok, ignore} -> + gen:unregister_name(Name0), proc_lib:init_ack(Starter, ignore), exit(normal); - {'EXIT', Reason} -> - unregister_name(Name0), - proc_lib:init_ack(Starter, {error, Reason}), - exit(Reason); - Else -> + {ok, Else} -> Error = {bad_return_value, Else}, proc_lib:init_ack(Starter, {error, Error}), - exit(Error) + exit(Error); + {'EXIT', Class, Reason, Stacktrace} -> + gen:unregister_name(Name0), + proc_lib:init_ack(Starter, {error, terminate_reason(Class, Reason, Stacktrace)}), + erlang:raise(Class, Reason, Stacktrace) + end. +init_it(Mod, Args) -> + try + {ok, Mod:init(Args)} + catch + throw:R -> {ok, R}; + Class:R -> {'EXIT', Class, R, erlang:get_stacktrace()} end. -name({local,Name}) -> Name; -name({global,Name}) -> Name; -name({via,_, Name}) -> Name; -name(Pid) when is_pid(Pid) -> Pid. - -unregister_name({local,Name}) -> - _ = (catch unregister(Name)); -unregister_name({global,Name}) -> - _ = global:unregister_name(Name); -unregister_name({via, Mod, Name}) -> - _ = Mod:unregister_name(Name); -unregister_name(Pid) when is_pid(Pid) -> - Pid. - %%%======================================================================== %%% Internal functions %%%======================================================================== %%% --------------------------------------------------- %%% The MAIN loop. %%% --------------------------------------------------- -loop(Parent, Name, State, Mod, hibernate, Debug) -> - proc_lib:hibernate(?MODULE,wake_hib,[Parent, Name, State, Mod, Debug]); -loop(Parent, Name, State, Mod, Time, Debug) -> +loop(Parent, Name, State, Mod, hibernate, HibernateAfterTimeout, Debug) -> + proc_lib:hibernate(?MODULE,wake_hib,[Parent, Name, State, Mod, HibernateAfterTimeout, Debug]); + +loop(Parent, Name, State, Mod, infinity, HibernateAfterTimeout, Debug) -> + receive + Msg -> + decode_msg(Msg, Parent, Name, State, Mod, infinity, HibernateAfterTimeout, Debug, false) + after HibernateAfterTimeout -> + loop(Parent, Name, State, Mod, hibernate, HibernateAfterTimeout, Debug) + end; + +loop(Parent, Name, State, Mod, Time, HibernateAfterTimeout, Debug) -> Msg = receive Input -> Input after Time -> timeout end, - decode_msg(Msg, Parent, Name, State, Mod, Time, Debug, false). + decode_msg(Msg, Parent, Name, State, Mod, Time, HibernateAfterTimeout, Debug, false). -wake_hib(Parent, Name, State, Mod, Debug) -> +wake_hib(Parent, Name, State, Mod, HibernateAfterTimeout, Debug) -> Msg = receive Input -> Input end, - decode_msg(Msg, Parent, Name, State, Mod, hibernate, Debug, true). + decode_msg(Msg, Parent, Name, State, Mod, hibernate, HibernateAfterTimeout, Debug, true). -decode_msg(Msg, Parent, Name, State, Mod, Time, Debug, Hib) -> +decode_msg(Msg, Parent, Name, State, Mod, Time, HibernateAfterTimeout, Debug, Hib) -> case Msg of {system, From, Req} -> sys:handle_system_msg(Req, From, Parent, ?MODULE, Debug, - [Name, State, Mod, Time], Hib); + [Name, State, Mod, Time, HibernateAfterTimeout], Hib); {'EXIT', Parent, Reason} -> - terminate(Reason, Name, Msg, Mod, State, Debug); + terminate(Reason, ?STACKTRACE(), Name, undefined, Msg, Mod, State, Debug); _Msg when Debug =:= [] -> - handle_msg(Msg, Parent, Name, State, Mod); + handle_msg(Msg, Parent, Name, State, Mod, HibernateAfterTimeout); _Msg -> Debug1 = sys:handle_debug(Debug, fun print_event/3, Name, {in, Msg}), - handle_msg(Msg, Parent, Name, State, Mod, Debug1) + handle_msg(Msg, Parent, Name, State, Mod, HibernateAfterTimeout, Debug1) end. %%% --------------------------------------------------- @@ -592,17 +599,11 @@ start_monitor(Node, Name) when is_atom(Node), is_atom(Name) -> %% --------------------------------------------------- %% Helper functions for try-catch of callbacks. %% Returns the return value of the callback, or -%% {'EXIT', ExitReason, ReportReason} (if an exception occurs) -%% -%% ExitReason is the reason that shall be used when the process -%% terminates. +%% {'EXIT', Class, Reason, Stack} (if an exception occurs) %% -%% ReportReason is the reason that shall be printed in the error -%% report. -%% -%% These functions are introduced in order to add the stack trace in -%% the error report produced when a callback is terminated with -%% erlang:exit/1 (OTP-12263). +%% The Class, Reason and Stack are given to erlang:raise/3 +%% to make sure proc_lib receives the proper reasons and +%% stacktraces. %% --------------------------------------------------- try_dispatch({'$gen_cast', Msg}, Mod, State) -> @@ -616,12 +617,18 @@ try_dispatch(Mod, Func, Msg, State) -> catch throw:R -> {ok, R}; - error:R -> - Stacktrace = erlang:get_stacktrace(), - {'EXIT', {R, Stacktrace}, {R, Stacktrace}}; - exit:R -> - Stacktrace = erlang:get_stacktrace(), - {'EXIT', R, {R, Stacktrace}} + error:undef = R when Func == handle_info -> + case erlang:function_exported(Mod, handle_info, 2) of + false -> + error_logger:warning_msg("** Undefined handle_info in ~p~n" + "** Unhandled message: ~tp~n", + [Mod, Msg]), + {ok, {noreply, State}}; + true -> + {'EXIT', error, R, erlang:get_stacktrace()} + end; + Class:R -> + {'EXIT', Class, R, erlang:get_stacktrace()} end. try_handle_call(Mod, Msg, From, State) -> @@ -630,26 +637,23 @@ try_handle_call(Mod, Msg, From, State) -> catch throw:R -> {ok, R}; - error:R -> - Stacktrace = erlang:get_stacktrace(), - {'EXIT', {R, Stacktrace}, {R, Stacktrace}}; - exit:R -> - Stacktrace = erlang:get_stacktrace(), - {'EXIT', R, {R, Stacktrace}} + Class:R -> + {'EXIT', Class, R, erlang:get_stacktrace()} end. try_terminate(Mod, Reason, State) -> - try - {ok, Mod:terminate(Reason, State)} - catch - throw:R -> - {ok, R}; - error:R -> - Stacktrace = erlang:get_stacktrace(), - {'EXIT', {R, Stacktrace}, {R, Stacktrace}}; - exit:R -> - Stacktrace = erlang:get_stacktrace(), - {'EXIT', R, {R, Stacktrace}} + case erlang:function_exported(Mod, terminate, 2) of + true -> + try + {ok, Mod:terminate(Reason, State)} + catch + throw:R -> + {ok, R}; + Class:R -> + {'EXIT', Class, R, erlang:get_stacktrace()} + end; + false -> + {ok, ok} end. @@ -657,89 +661,91 @@ try_terminate(Mod, Reason, State) -> %%% Message handling functions %%% --------------------------------------------------- -handle_msg({'$gen_call', From, Msg}, Parent, Name, State, Mod) -> +handle_msg({'$gen_call', From, Msg}, Parent, Name, State, Mod, HibernateAfterTimeout) -> Result = try_handle_call(Mod, Msg, From, State), case Result of {ok, {reply, Reply, NState}} -> reply(From, Reply), - loop(Parent, Name, NState, Mod, infinity, []); + loop(Parent, Name, NState, Mod, infinity, HibernateAfterTimeout, []); {ok, {reply, Reply, NState, Time1}} -> reply(From, Reply), - loop(Parent, Name, NState, Mod, Time1, []); + loop(Parent, Name, NState, Mod, Time1, HibernateAfterTimeout, []); {ok, {noreply, NState}} -> - loop(Parent, Name, NState, Mod, infinity, []); + loop(Parent, Name, NState, Mod, infinity, HibernateAfterTimeout, []); {ok, {noreply, NState, Time1}} -> - loop(Parent, Name, NState, Mod, Time1, []); + loop(Parent, Name, NState, Mod, Time1, HibernateAfterTimeout, []); {ok, {stop, Reason, Reply, NState}} -> - {'EXIT', R} = - (catch terminate(Reason, Name, Msg, Mod, NState, [])), - reply(From, Reply), - exit(R); - Other -> handle_common_reply(Other, Parent, Name, Msg, Mod, State) + try + terminate(Reason, ?STACKTRACE(), Name, From, Msg, Mod, NState, []) + after + reply(From, Reply) + end; + Other -> handle_common_reply(Other, Parent, Name, From, Msg, Mod, HibernateAfterTimeout, State) end; -handle_msg(Msg, Parent, Name, State, Mod) -> +handle_msg(Msg, Parent, Name, State, Mod, HibernateAfterTimeout) -> Reply = try_dispatch(Msg, Mod, State), - handle_common_reply(Reply, Parent, Name, Msg, Mod, State). + handle_common_reply(Reply, Parent, Name, undefined, Msg, Mod, HibernateAfterTimeout, State). -handle_msg({'$gen_call', From, Msg}, Parent, Name, State, Mod, Debug) -> +handle_msg({'$gen_call', From, Msg}, Parent, Name, State, Mod, HibernateAfterTimeout, Debug) -> Result = try_handle_call(Mod, Msg, From, State), case Result of {ok, {reply, Reply, NState}} -> Debug1 = reply(Name, From, Reply, NState, Debug), - loop(Parent, Name, NState, Mod, infinity, Debug1); + loop(Parent, Name, NState, Mod, infinity, HibernateAfterTimeout, Debug1); {ok, {reply, Reply, NState, Time1}} -> Debug1 = reply(Name, From, Reply, NState, Debug), - loop(Parent, Name, NState, Mod, Time1, Debug1); + loop(Parent, Name, NState, Mod, Time1, HibernateAfterTimeout, Debug1); {ok, {noreply, NState}} -> Debug1 = sys:handle_debug(Debug, fun print_event/3, Name, {noreply, NState}), - loop(Parent, Name, NState, Mod, infinity, Debug1); + loop(Parent, Name, NState, Mod, infinity, HibernateAfterTimeout, Debug1); {ok, {noreply, NState, Time1}} -> Debug1 = sys:handle_debug(Debug, fun print_event/3, Name, {noreply, NState}), - loop(Parent, Name, NState, Mod, Time1, Debug1); + loop(Parent, Name, NState, Mod, Time1, HibernateAfterTimeout, Debug1); {ok, {stop, Reason, Reply, NState}} -> - {'EXIT', R} = - (catch terminate(Reason, Name, Msg, Mod, NState, Debug)), - _ = reply(Name, From, Reply, NState, Debug), - exit(R); + try + terminate(Reason, ?STACKTRACE(), Name, From, Msg, Mod, NState, Debug) + after + _ = reply(Name, From, Reply, NState, Debug) + end; Other -> - handle_common_reply(Other, Parent, Name, Msg, Mod, State, Debug) + handle_common_reply(Other, Parent, Name, From, Msg, Mod, HibernateAfterTimeout, State, Debug) end; -handle_msg(Msg, Parent, Name, State, Mod, Debug) -> +handle_msg(Msg, Parent, Name, State, Mod, HibernateAfterTimeout, Debug) -> Reply = try_dispatch(Msg, Mod, State), - handle_common_reply(Reply, Parent, Name, Msg, Mod, State, Debug). + handle_common_reply(Reply, Parent, Name, undefined, Msg, Mod, HibernateAfterTimeout, State, Debug). -handle_common_reply(Reply, Parent, Name, Msg, Mod, State) -> +handle_common_reply(Reply, Parent, Name, From, Msg, Mod, HibernateAfterTimeout, State) -> case Reply of {ok, {noreply, NState}} -> - loop(Parent, Name, NState, Mod, infinity, []); + loop(Parent, Name, NState, Mod, infinity, HibernateAfterTimeout, []); {ok, {noreply, NState, Time1}} -> - loop(Parent, Name, NState, Mod, Time1, []); + loop(Parent, Name, NState, Mod, Time1, HibernateAfterTimeout, []); {ok, {stop, Reason, NState}} -> - terminate(Reason, Name, Msg, Mod, NState, []); - {'EXIT', ExitReason, ReportReason} -> - terminate(ExitReason, ReportReason, Name, Msg, Mod, State, []); + terminate(Reason, ?STACKTRACE(), Name, From, Msg, Mod, NState, []); + {'EXIT', Class, Reason, Stacktrace} -> + terminate(Class, Reason, Stacktrace, Name, From, Msg, Mod, State, []); {ok, BadReply} -> - terminate({bad_return_value, BadReply}, Name, Msg, Mod, State, []) + terminate({bad_return_value, BadReply}, ?STACKTRACE(), Name, From, Msg, Mod, State, []) end. -handle_common_reply(Reply, Parent, Name, Msg, Mod, State, Debug) -> +handle_common_reply(Reply, Parent, Name, From, Msg, Mod, HibernateAfterTimeout, State, Debug) -> case Reply of {ok, {noreply, NState}} -> Debug1 = sys:handle_debug(Debug, fun print_event/3, Name, {noreply, NState}), - loop(Parent, Name, NState, Mod, infinity, Debug1); + loop(Parent, Name, NState, Mod, infinity, HibernateAfterTimeout, Debug1); {ok, {noreply, NState, Time1}} -> Debug1 = sys:handle_debug(Debug, fun print_event/3, Name, {noreply, NState}), - loop(Parent, Name, NState, Mod, Time1, Debug1); + loop(Parent, Name, NState, Mod, Time1, HibernateAfterTimeout, Debug1); {ok, {stop, Reason, NState}} -> - terminate(Reason, Name, Msg, Mod, NState, Debug); - {'EXIT', ExitReason, ReportReason} -> - terminate(ExitReason, ReportReason, Name, Msg, Mod, State, Debug); + terminate(Reason, ?STACKTRACE(), Name, From, Msg, Mod, NState, Debug); + {'EXIT', Class, Reason, Stacktrace} -> + terminate(Class, Reason, Stacktrace, Name, From, Msg, Mod, State, Debug); {ok, BadReply} -> - terminate({bad_return_value, BadReply}, Name, Msg, Mod, State, Debug) + terminate({bad_return_value, BadReply}, ?STACKTRACE(), Name, From, Msg, Mod, State, Debug) end. reply(Name, {To, Tag}, Reply, State, Debug) -> @@ -751,26 +757,26 @@ reply(Name, {To, Tag}, Reply, State, Debug) -> %%----------------------------------------------------------------- %% Callback functions for system messages handling. %%----------------------------------------------------------------- -system_continue(Parent, Debug, [Name, State, Mod, Time]) -> - loop(Parent, Name, State, Mod, Time, Debug). +system_continue(Parent, Debug, [Name, State, Mod, Time, HibernateAfterTimeout]) -> + loop(Parent, Name, State, Mod, Time, HibernateAfterTimeout, Debug). -spec system_terminate(_, _, _, [_]) -> no_return(). -system_terminate(Reason, _Parent, Debug, [Name, State, Mod, _Time]) -> - terminate(Reason, Name, [], Mod, State, Debug). +system_terminate(Reason, _Parent, Debug, [Name, State, Mod, _Time, _HibernateAfterTimeout]) -> + terminate(Reason, ?STACKTRACE(), Name, undefined, [], Mod, State, Debug). -system_code_change([Name, State, Mod, Time], _Module, OldVsn, Extra) -> +system_code_change([Name, State, Mod, Time, HibernateAfterTimeout], _Module, OldVsn, Extra) -> case catch Mod:code_change(OldVsn, State, Extra) of - {ok, NewState} -> {ok, [Name, NewState, Mod, Time]}; + {ok, NewState} -> {ok, [Name, NewState, Mod, Time, HibernateAfterTimeout]}; Else -> Else end. -system_get_state([_Name, State, _Mod, _Time]) -> +system_get_state([_Name, State, _Mod, _Time, _HibernateAfterTimeout]) -> {ok, State}. -system_replace_state(StateFun, [Name, State, Mod, Time]) -> +system_replace_state(StateFun, [Name, State, Mod, Time, HibernateAfterTimeout]) -> NState = StateFun(State), - {ok, NState, [Name, NState, Mod, Time]}. + {ok, NState, [Name, NState, Mod, Time, HibernateAfterTimeout]}. %%----------------------------------------------------------------- %% Format debug messages. Print them as the call-back module sees @@ -779,60 +785,83 @@ system_replace_state(StateFun, [Name, State, Mod, Time]) -> print_event(Dev, {in, Msg}, Name) -> case Msg of {'$gen_call', {From, _Tag}, Call} -> - io:format(Dev, "*DBG* ~p got call ~p from ~w~n", + io:format(Dev, "*DBG* ~tp got call ~tp from ~w~n", [Name, Call, From]); {'$gen_cast', Cast} -> - io:format(Dev, "*DBG* ~p got cast ~p~n", + io:format(Dev, "*DBG* ~tp got cast ~tp~n", [Name, Cast]); _ -> - io:format(Dev, "*DBG* ~p got ~p~n", [Name, Msg]) + io:format(Dev, "*DBG* ~tp got ~tp~n", [Name, Msg]) end; print_event(Dev, {out, Msg, To, State}, Name) -> - io:format(Dev, "*DBG* ~p sent ~p to ~w, new state ~w~n", + io:format(Dev, "*DBG* ~tp sent ~tp to ~w, new state ~tp~n", [Name, Msg, To, State]); print_event(Dev, {noreply, State}, Name) -> - io:format(Dev, "*DBG* ~p new state ~w~n", [Name, State]); + io:format(Dev, "*DBG* ~tp new state ~tp~n", [Name, State]); print_event(Dev, Event, Name) -> - io:format(Dev, "*DBG* ~p dbg ~p~n", [Name, Event]). + io:format(Dev, "*DBG* ~tp dbg ~tp~n", [Name, Event]). %%% --------------------------------------------------- %%% Terminate the server. +%%% +%%% terminate/8 is triggered by {stop, Reason} or bad +%%% return values. The stacktrace is generated via the +%%% ?STACKTRACE() macro and the ReportReason must not +%%% be wrapped in tuples. +%%% +%%% terminate/9 is triggered in case of error/exit in +%%% the user callback. In this case the report reason +%%% always includes the user stacktrace. +%%% +%%% The reason received in the terminate/2 callbacks +%%% always includes the stacktrace for errors and never +%%% for exits. %%% --------------------------------------------------- --spec terminate(_, _, _, _, _, _) -> no_return(). -terminate(Reason, Name, Msg, Mod, State, Debug) -> - terminate(Reason, Reason, Name, Msg, Mod, State, Debug). +-spec terminate(_, _, _, _, _, _, _, _) -> no_return(). +terminate(Reason, Stacktrace, Name, From, Msg, Mod, State, Debug) -> + terminate(exit, Reason, Stacktrace, Reason, Name, From, Msg, Mod, State, Debug). --spec terminate(_, _, _, _, _, _, _) -> no_return(). -terminate(ExitReason, ReportReason, Name, Msg, Mod, State, Debug) -> - Reply = try_terminate(Mod, ExitReason, State), +-spec terminate(_, _, _, _, _, _, _, _, _) -> no_return(). +terminate(Class, Reason, Stacktrace, Name, From, Msg, Mod, State, Debug) -> + ReportReason = {Reason, Stacktrace}, + terminate(Class, Reason, Stacktrace, ReportReason, Name, From, Msg, Mod, State, Debug). + +-spec terminate(_, _, _, _, _, _, _, _, _, _) -> no_return(). +terminate(Class, Reason, Stacktrace, ReportReason, Name, From, Msg, Mod, State, Debug) -> + Reply = try_terminate(Mod, terminate_reason(Class, Reason, Stacktrace), State), case Reply of - {'EXIT', ExitReason1, ReportReason1} -> + {'EXIT', C, R, S} -> FmtState = format_status(terminate, Mod, get(), State), - error_info(ReportReason1, Name, Msg, FmtState, Debug), - exit(ExitReason1); + error_info({R, S}, Name, From, Msg, FmtState, Debug), + erlang:raise(C, R, S); _ -> - case ExitReason of - normal -> - exit(normal); - shutdown -> - exit(shutdown); - {shutdown,_}=Shutdown -> - exit(Shutdown); + case {Class, Reason} of + {exit, normal} -> ok; + {exit, shutdown} -> ok; + {exit, {shutdown,_}} -> ok; _ -> FmtState = format_status(terminate, Mod, get(), State), - error_info(ReportReason, Name, Msg, FmtState, Debug), - exit(ExitReason) + error_info(ReportReason, Name, From, Msg, FmtState, Debug) end + end, + case Stacktrace of + [] -> + erlang:Class(Reason); + _ -> + erlang:raise(Class, Reason, Stacktrace) end. -error_info(_Reason, application_controller, _Msg, _State, _Debug) -> +terminate_reason(error, Reason, Stacktrace) -> {Reason, Stacktrace}; +terminate_reason(exit, Reason, _Stacktrace) -> Reason. + +error_info(_Reason, application_controller, _From, _Msg, _State, _Debug) -> %% OTP-5811 Don't send an error report if it's the system process %% application_controller which is terminating - let init take care %% of it instead ok; -error_info(Reason, Name, Msg, State, Debug) -> +error_info(Reason, Name, From, Msg, State, Debug) -> Reason1 = case Reason of {undef,[{M,F,A,L}|MFAs]} -> @@ -848,101 +877,42 @@ error_info(Reason, Name, Msg, State, Debug) -> end end; _ -> - Reason + error_logger:limit_term(Reason) end, - format("** Generic server ~p terminating \n" - "** Last message in was ~p~n" - "** When Server state == ~p~n" - "** Reason for termination == ~n** ~p~n", - [Name, Msg, State, Reason1]), + {ClientFmt, ClientArgs} = client_stacktrace(From), + LimitedState = error_logger:limit_term(State), + error_logger:format("** Generic server ~tp terminating \n" + "** Last message in was ~tp~n" + "** When Server state == ~tp~n" + "** Reason for termination == ~n** ~tp~n" ++ ClientFmt, + [Name, Msg, LimitedState, Reason1] ++ ClientArgs), sys:print_log(Debug), ok. - -%%% --------------------------------------------------- -%%% Misc. functions. -%%% --------------------------------------------------- - -opt(Op, [{Op, Value}|_]) -> - {ok, Value}; -opt(Op, [_|Options]) -> - opt(Op, Options); -opt(_, []) -> - false. - -debug_options(Name, Opts) -> - case opt(debug, Opts) of - {ok, Options} -> dbg_opts(Name, Options); - _ -> [] - end. - -dbg_opts(Name, Opts) -> - case catch sys:debug_options(Opts) of - {'EXIT',_} -> - format("~p: ignoring erroneous debug options - ~p~n", - [Name, Opts]), - []; - Dbg -> - Dbg - end. - -get_proc_name(Pid) when is_pid(Pid) -> - Pid; -get_proc_name({local, Name}) -> - case process_info(self(), registered_name) of - {registered_name, Name} -> - Name; - {registered_name, _Name} -> - exit(process_not_registered); - [] -> - exit(process_not_registered) - end; -get_proc_name({global, Name}) -> - case global:whereis_name(Name) of - undefined -> - exit(process_not_registered_globally); - Pid when Pid =:= self() -> - Name; - _Pid -> - exit(process_not_registered_globally) +client_stacktrace(undefined) -> + {"", []}; +client_stacktrace({From, _Tag}) -> + client_stacktrace(From); +client_stacktrace(From) when is_pid(From), node(From) =:= node() -> + case process_info(From, [current_stacktrace, registered_name]) of + undefined -> + {"** Client ~p is dead~n", [From]}; + [{current_stacktrace, Stacktrace}, {registered_name, []}] -> + {"** Client ~p stacktrace~n" + "** ~tp~n", + [From, Stacktrace]}; + [{current_stacktrace, Stacktrace}, {registered_name, Name}] -> + {"** Client ~tp stacktrace~n" + "** ~tp~n", + [Name, Stacktrace]} end; -get_proc_name({via, Mod, Name}) -> - case Mod:whereis_name(Name) of - undefined -> - exit({process_not_registered_via, Mod}); - Pid when Pid =:= self() -> - Name; - _Pid -> - exit({process_not_registered_via, Mod}) - end. - -get_parent() -> - case get('$ancestors') of - [Parent | _] when is_pid(Parent)-> - Parent; - [Parent | _] when is_atom(Parent)-> - name_to_pid(Parent); - _ -> - exit(process_was_not_started_by_proc_lib) - end. - -name_to_pid(Name) -> - case whereis(Name) of - undefined -> - case global:whereis_name(Name) of - undefined -> - exit(could_not_find_registered_name); - Pid -> - Pid - end; - Pid -> - Pid - end. +client_stacktrace(From) when is_pid(From) -> + {"** Client ~p is remote on node ~p~n", [From, node(From)]}. %%----------------------------------------------------------------- %% Status information %%----------------------------------------------------------------- format_status(Opt, StatusData) -> - [PDict, SysState, Parent, Debug, [Name, State, Mod, _Time]] = StatusData, + [PDict, SysState, Parent, Debug, [Name, State, Mod, _Time, _HibernateAfterTimeout]] = StatusData, Header = gen:format_status_header("Status for generic server", Name), Log = sys:get_debug(log, Debug, []), Specfic = case format_status(Opt, Mod, PDict, State) of diff --git a/lib/stdlib/src/gen_statem.erl b/lib/stdlib/src/gen_statem.erl new file mode 100644 index 0000000000..eb0d6bd742 --- /dev/null +++ b/lib/stdlib/src/gen_statem.erl @@ -0,0 +1,2007 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2016-2018. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% +%% +-module(gen_statem). + +%% API +-export( + [start/3,start/4,start_link/3,start_link/4, + stop/1,stop/3, + cast/2,call/2,call/3, + enter_loop/4,enter_loop/5,enter_loop/6, + reply/1,reply/2]). + +%% gen callbacks +-export( + [init_it/6]). + +%% sys callbacks +-export( + [system_continue/3, + system_terminate/4, + system_code_change/4, + system_get_state/1, + system_replace_state/2, + format_status/2]). + +%% Internal callbacks +-export( + [wakeup_from_hibernate/3]). + +%% Type exports for templates and callback modules +-export_type( + [event_type/0, + callback_mode_result/0, + init_result/1, + state_enter_result/1, + event_handler_result/1, + reply_action/0, + enter_action/0, + action/0]). +%% Old types, not advertised +-export_type( + [state_function_result/0, + handle_event_result/0]). + +%% Type that is exported just to be documented +-export_type([transition_option/0]). + +%%%========================================================================== +%%% Interface functions. +%%%========================================================================== + +-type from() :: + {To :: pid(), Tag :: term()}. % Reply-to specifier for call + +-type state() :: + state_name() | % For StateName/3 callback functions + term(). % For handle_event/4 callback function + +-type state_name() :: atom(). + +-type data() :: term(). + +-type event_type() :: + external_event_type() | timeout_event_type() | 'internal'. +-type external_event_type() :: + {'call',From :: from()} | 'cast' | 'info'. +-type timeout_event_type() :: + 'timeout' | {'timeout', Name :: term()} | 'state_timeout'. + +-type callback_mode_result() :: + callback_mode() | [callback_mode() | state_enter()]. +-type callback_mode() :: 'state_functions' | 'handle_event_function'. +-type state_enter() :: 'state_enter'. + +-type transition_option() :: + postpone() | hibernate() | + event_timeout() | generic_timeout() | state_timeout(). +-type postpone() :: + %% If 'true' postpone the current event + %% and retry it when the state changes (=/=) + boolean(). +-type hibernate() :: + %% If 'true' hibernate the server instead of going into receive + boolean(). +-type event_timeout() :: + %% Generate a ('timeout', EventContent, ...) event + %% unless some other event is delivered + Time :: timeout() | integer(). +-type generic_timeout() :: + %% Generate a ({'timeout',Name}, EventContent, ...) event + Time :: timeout() | integer(). +-type state_timeout() :: + %% Generate a ('state_timeout', EventContent, ...) event + %% unless the state is changed + Time :: timeout() | integer(). +-type timeout_option() :: {abs,Abs :: boolean()}. + +-type action() :: + %% During a state change: + %% * NextState and NewData are set. + %% * All action()s are executed in order of apperance. + %% * Postponing the current event is performed + %% iff 'postpone' is 'true'. + %% * A state timeout is started iff 'timeout' is set. + %% * Pending events are handled or if there are + %% no pending events the server goes into receive + %% or hibernate (iff 'hibernate' is 'true') + %% + %% These action()s are executed in order of appearence + %% in the containing list. The ones that set options + %% will override any previous so the last of each kind wins. + %% + 'postpone' | % Set the postpone option + {'postpone', Postpone :: postpone()} | + %% + %% All 'next_event' events are kept in a list and then + %% inserted at state changes so the first in the + %% action() list is the first to be delivered. + {'next_event', % Insert event as the next to handle + EventType :: event_type(), + EventContent :: term()} | + enter_action(). +-type enter_action() :: + 'hibernate' | % Set the hibernate option + {'hibernate', Hibernate :: hibernate()} | + timeout_action() | + reply_action(). +-type timeout_action() :: + (Timeout :: event_timeout()) | % {timeout,Timeout} + {'timeout', % Set the event_timeout option + Time :: event_timeout(), EventContent :: term()} | + {'timeout', % Set the event_timeout option + Time :: event_timeout(), + EventContent :: term(), + Options :: (timeout_option() | [timeout_option()])} | + %% + {{'timeout', Name :: term()}, % Set the generic_timeout option + Time :: generic_timeout(), EventContent :: term()} | + {{'timeout', Name :: term()}, % Set the generic_timeout option + Time :: generic_timeout(), + EventContent :: term(), + Options :: (timeout_option() | [timeout_option()])} | + %% + {'state_timeout', % Set the state_timeout option + Time :: state_timeout(), EventContent :: term()} | + {'state_timeout', % Set the state_timeout option + Time :: state_timeout(), + EventContent :: term(), + Options :: (timeout_option() | [timeout_option()])}. +-type reply_action() :: + {'reply', % Reply to a caller + From :: from(), Reply :: term()}. + +-type init_result(StateType) :: + {ok, State :: StateType, Data :: data()} | + {ok, State :: StateType, Data :: data(), + Actions :: [action()] | action()} | + 'ignore' | + {'stop', Reason :: term()}. + +%% Old, not advertised +-type state_function_result() :: + event_handler_result(state_name()). +-type handle_event_result() :: + event_handler_result(state()). +%% +-type state_enter_result(State) :: + {'next_state', % {next_state,NextState,NewData,[]} + State, + NewData :: data()} | + {'next_state', % State transition, maybe to the same state + State, + NewData :: data(), + Actions :: [enter_action()] | enter_action()} | + state_callback_result(enter_action()). +-type event_handler_result(StateType) :: + {'next_state', % {next_state,NextState,NewData,[]} + NextState :: StateType, + NewData :: data()} | + {'next_state', % State transition, maybe to the same state + NextState :: StateType, + NewData :: data(), + Actions :: [action()] | action()} | + state_callback_result(action()). +-type state_callback_result(ActionType) :: + {'keep_state', % {keep_state,NewData,[]} + NewData :: data()} | + {'keep_state', % Keep state, change data + NewData :: data(), + Actions :: [ActionType] | ActionType} | + 'keep_state_and_data' | % {keep_state_and_data,[]} + {'keep_state_and_data', % Keep state and data -> only actions + Actions :: [ActionType] | ActionType} | + %% + {'repeat_state', % {repeat_state,NewData,[]} + NewData :: data()} | + {'repeat_state', % Repeat state, change data + NewData :: data(), + Actions :: [ActionType] | ActionType} | + 'repeat_state_and_data' | % {repeat_state_and_data,[]} + {'repeat_state_and_data', % Repeat state and data -> only actions + Actions :: [ActionType] | ActionType} | + %% + 'stop' | % {stop,normal} + {'stop', % Stop the server + Reason :: term()} | + {'stop', % Stop the server + Reason :: term(), + NewData :: data()} | + %% + {'stop_and_reply', % Reply then stop the server + Reason :: term(), + Replies :: [reply_action()] | reply_action()} | + {'stop_and_reply', % Reply then stop the server + Reason :: term(), + Replies :: [reply_action()] | reply_action(), + NewData :: data()}. + + +%% The state machine init function. It is called only once and +%% the server is not running until this function has returned +%% an {ok, ...} tuple. Thereafter the state callbacks are called +%% for all events to this server. +-callback init(Args :: term()) -> init_result(state()). + +%% This callback shall return the callback mode of the callback module. +%% +%% It is called once after init/0 and code_change/4 but before +%% the first state callback StateName/3 or handle_event/4. +-callback callback_mode() -> callback_mode_result(). + +%% Example state callback for StateName = 'state_name' +%% when callback_mode() =:= state_functions. +%% +%% In this mode all states has to be of type state_name() i.e atom(). +%% +%% Note that the only callbacks that have arity 3 are these +%% StateName/3 callbacks and terminate/3, so the state name +%% 'terminate' is unusable in this mode. +-callback state_name( + 'enter', + OldStateName :: state_name(), + Data :: data()) -> + state_enter_result('state_name'); + (event_type(), + EventContent :: term(), + Data :: data()) -> + event_handler_result(state_name()). +%% +%% State callback for all states +%% when callback_mode() =:= handle_event_function. +-callback handle_event( + 'enter', + OldState :: state(), + State, % Current state + Data :: data()) -> + state_enter_result(State); + (event_type(), + EventContent :: term(), + State :: state(), % Current state + Data :: data()) -> + event_handler_result(state()). + +%% Clean up before the server terminates. +-callback terminate( + Reason :: 'normal' | 'shutdown' | {'shutdown', term()} + | term(), + State :: state(), + Data :: data()) -> + any(). + +%% Note that the new code can expect to get an OldState from +%% the old code version not only in code_change/4 but in the first +%% state callback function called thereafter +-callback code_change( + OldVsn :: term() | {'down', term()}, + OldState :: state(), + OldData :: data(), + Extra :: term()) -> + {ok, NewState :: state(), NewData :: data()} | + (Reason :: term()). + +%% Format the callback module state in some sensible that is +%% often condensed way. For StatusOption =:= 'normal' the perferred +%% return term is [{data,[{"State",FormattedState}]}], and for +%% StatusOption =:= 'terminate' it is just FormattedState. +-callback format_status( + StatusOption, + [ [{Key :: term(), Value :: term()}] | + state() | + data()]) -> + Status :: term() when + StatusOption :: 'normal' | 'terminate'. + +-optional_callbacks( + [format_status/2, % Has got a default implementation + terminate/3, % Has got a default implementation + code_change/4, % Only needed by advanced soft upgrade + %% + state_name/3, % Example for callback_mode() =:= state_functions: + %% there has to be a StateName/3 callback function + %% for every StateName in your state machine but the state name + %% 'state_name' does of course not have to be used. + %% + handle_event/4 % For callback_mode() =:= handle_event_function + ]). + + + +%% Type validation functions +-compile( + {inline, + [callback_mode/1, state_enter/1, from/1, event_type/1]}). +%% +callback_mode(CallbackMode) -> + case CallbackMode of + state_functions -> true; + handle_event_function -> true; + _ -> false + end. +%% +state_enter(StateEnter) -> + case StateEnter of + state_enter -> + true; + _ -> + false + end. +%% +from({Pid,_}) when is_pid(Pid) -> true; +from(_) -> false. +%% +event_type({call,From}) -> + from(From); +event_type(Type) -> + case Type of + {call,From} -> from(From); + cast -> true; + info -> true; + timeout -> true; + state_timeout -> true; + internal -> true; + {timeout,_} -> true; + _ -> false + end. + + + +-define( + STACKTRACE(), + try throw(ok) catch _ -> erlang:get_stacktrace() end). + +-define(not_sys_debug, []). +%% +%% This is a macro to only evaluate arguments if Debug =/= []. +%% Debug is evaluated multiple times. +-define( + sys_debug(Debug, NameState, Entry), + case begin Debug end of + ?not_sys_debug -> + begin Debug end; + _ -> + sys_debug(begin Debug end, begin NameState end, begin Entry end) + end). + +-record(state, + {callback_mode = undefined :: callback_mode() | undefined, + state_enter = false :: boolean(), + module :: atom(), + name :: atom(), + state :: term(), + data :: term(), + postponed = [] :: [{event_type(),term()}], + %% + timer_refs = #{} :: % timer ref => the timer's event type + #{reference() => timeout_event_type()}, + timer_types = #{} :: % timer's event type => timer ref + #{timeout_event_type() => reference()}, + cancel_timers = 0 :: non_neg_integer(), + %% We add a timer to both timer_refs and timer_types + %% when we start it. When we request an asynchronous + %% timer cancel we remove it from timer_types. When + %% the timer cancel message arrives we remove it from + %% timer_refs. + %% + hibernate = false :: boolean(), + hibernate_after = infinity :: timeout()}). + +-record(trans_opts, + {hibernate = false, + postpone = false, + timeouts_r = [], + next_events_r = []}). + +%%%========================================================================== +%%% API + +-type server_name() :: + {'global', GlobalName :: term()} + | {'via', RegMod :: module(), Name :: term()} + | {'local', atom()}. +-type server_ref() :: + pid() + | (LocalName :: atom()) + | {Name :: atom(), Node :: atom()} + | {'global', GlobalName :: term()} + | {'via', RegMod :: module(), ViaName :: term()}. +-type debug_opt() :: + {'debug', + Dbgs :: + ['trace' | 'log' | 'statistics' | 'debug' + | {'logfile', string()}]}. +-type hibernate_after_opt() :: + {'hibernate_after', HibernateAfterTimeout :: timeout()}. +-type start_opt() :: + debug_opt() + | {'timeout', Time :: timeout()} + | hibernate_after_opt() + | {'spawn_opt', [proc_lib:spawn_option()]}. +-type start_ret() :: {'ok', pid()} | 'ignore' | {'error', term()}. + + + +%% Start a state machine +-spec start( + Module :: module(), Args :: term(), Opts :: [start_opt()]) -> + start_ret(). +start(Module, Args, Opts) -> + gen:start(?MODULE, nolink, Module, Args, Opts). +%% +-spec start( + ServerName :: server_name(), + Module :: module(), Args :: term(), Opts :: [start_opt()]) -> + start_ret(). +start(ServerName, Module, Args, Opts) -> + gen:start(?MODULE, nolink, ServerName, Module, Args, Opts). + +%% Start and link to a state machine +-spec start_link( + Module :: module(), Args :: term(), Opts :: [start_opt()]) -> + start_ret(). +start_link(Module, Args, Opts) -> + gen:start(?MODULE, link, Module, Args, Opts). +%% +-spec start_link( + ServerName :: server_name(), + Module :: module(), Args :: term(), Opts :: [start_opt()]) -> + start_ret(). +start_link(ServerName, Module, Args, Opts) -> + gen:start(?MODULE, link, ServerName, Module, Args, Opts). + +%% Stop a state machine +-spec stop(ServerRef :: server_ref()) -> ok. +stop(ServerRef) -> + gen:stop(ServerRef). +%% +-spec stop( + ServerRef :: server_ref(), + Reason :: term(), + Timeout :: timeout()) -> ok. +stop(ServerRef, Reason, Timeout) -> + gen:stop(ServerRef, Reason, Timeout). + +%% Send an event to a state machine that arrives with type 'event' +-spec cast(ServerRef :: server_ref(), Msg :: term()) -> ok. +cast(ServerRef, Msg) when is_pid(ServerRef) -> + send(ServerRef, wrap_cast(Msg)); +cast(ServerRef, Msg) when is_atom(ServerRef) -> + send(ServerRef, wrap_cast(Msg)); +cast({global,Name}, Msg) -> + try global:send(Name, wrap_cast(Msg)) of + _ -> ok + catch + _:_ -> ok + end; +cast({via,RegMod,Name}, Msg) -> + try RegMod:send(Name, wrap_cast(Msg)) of + _ -> ok + catch + _:_ -> ok + end; +cast({Name,Node} = ServerRef, Msg) when is_atom(Name), is_atom(Node) -> + send(ServerRef, wrap_cast(Msg)). + +%% Call a state machine (synchronous; a reply is expected) that +%% arrives with type {call,From} +-spec call(ServerRef :: server_ref(), Request :: term()) -> Reply :: term(). +call(ServerRef, Request) -> + call(ServerRef, Request, infinity). +%% +-spec call( + ServerRef :: server_ref(), + Request :: term(), + Timeout :: + timeout() | + {'clean_timeout',T :: timeout()} | + {'dirty_timeout',T :: timeout()}) -> + Reply :: term(). +call(ServerRef, Request, infinity = T = Timeout) -> + call_dirty(ServerRef, Request, Timeout, T); +call(ServerRef, Request, {dirty_timeout, T} = Timeout) -> + call_dirty(ServerRef, Request, Timeout, T); +call(ServerRef, Request, {clean_timeout, infinity = T} = Timeout) -> + call_dirty(ServerRef, Request, Timeout, T); +call(ServerRef, Request, {clean_timeout, T} = Timeout) -> + call_clean(ServerRef, Request, Timeout, T); +call(ServerRef, Request, {_, _} = Timeout) -> + erlang:error(badarg, [ServerRef,Request,Timeout]); +call(ServerRef, Request, Timeout) -> + call_clean(ServerRef, Request, Timeout, Timeout). + +%% Reply from a state machine callback to whom awaits in call/2 +-spec reply([reply_action()] | reply_action()) -> ok. +reply({reply,From,Reply}) -> + reply(From, Reply); +reply(Replies) when is_list(Replies) -> + replies(Replies). +%% +-compile({inline, [reply/2]}). +-spec reply(From :: from(), Reply :: term()) -> ok. +reply({To,Tag}, Reply) when is_pid(To) -> + Msg = {Tag,Reply}, + try To ! Msg of + _ -> + ok + catch + _:_ -> ok + end. + +%% Instead of starting the state machine through start/3,4 +%% or start_link/3,4 turn the current process presumably +%% started by proc_lib into a state machine using +%% the same arguments as you would have returned from init/1 +-spec enter_loop( + Module :: module(), Opts :: [debug_opt() | hibernate_after_opt()], + State :: state(), Data :: data()) -> + no_return(). +enter_loop(Module, Opts, State, Data) -> + enter_loop(Module, Opts, State, Data, self()). +%% +-spec enter_loop( + Module :: module(), Opts :: [debug_opt() | hibernate_after_opt()], + State :: state(), Data :: data(), + Server_or_Actions :: + server_name() | pid() | [action()]) -> + no_return(). +enter_loop(Module, Opts, State, Data, Server_or_Actions) -> + if + is_list(Server_or_Actions) -> + enter_loop(Module, Opts, State, Data, self(), Server_or_Actions); + true -> + enter_loop(Module, Opts, State, Data, Server_or_Actions, []) + end. +%% +-spec enter_loop( + Module :: module(), Opts :: [debug_opt() | hibernate_after_opt()], + State :: state(), Data :: data(), + Server :: server_name() | pid(), + Actions :: [action()] | action()) -> + no_return(). +enter_loop(Module, Opts, State, Data, Server, Actions) -> + is_atom(Module) orelse error({atom,Module}), + Parent = gen:get_parent(), + enter(Module, Opts, State, Data, Server, Actions, Parent). + +%%--------------------------------------------------------------------------- +%% API helpers + +-compile({inline, [wrap_cast/1]}). +wrap_cast(Event) -> + {'$gen_cast',Event}. + +call_dirty(ServerRef, Request, Timeout, T) -> + try gen:call(ServerRef, '$gen_call', Request, T) of + {ok,Reply} -> + Reply + catch + Class:Reason -> + erlang:raise( + Class, + {Reason,{?MODULE,call,[ServerRef,Request,Timeout]}}, + erlang:get_stacktrace()) + end. + +call_clean(ServerRef, Request, Timeout, T) -> + %% Call server through proxy process to dodge any late reply + Ref = make_ref(), + Self = self(), + Pid = spawn( + fun () -> + Self ! + try gen:call( + ServerRef, '$gen_call', Request, T) of + Result -> + {Ref,Result} + catch Class:Reason -> + {Ref,Class,Reason, + erlang:get_stacktrace()} + end + end), + Mref = monitor(process, Pid), + receive + {Ref,Result} -> + demonitor(Mref, [flush]), + case Result of + {ok,Reply} -> + Reply + end; + {Ref,Class,Reason,Stacktrace} -> + demonitor(Mref, [flush]), + erlang:raise( + Class, + {Reason,{?MODULE,call,[ServerRef,Request,Timeout]}}, + Stacktrace); + {'DOWN',Mref,_,_,Reason} -> + %% There is a theoretical possibility that the + %% proxy process gets killed between try--of and ! + %% so this clause is in case of that + exit(Reason) + end. + +replies([{reply,From,Reply}|Replies]) -> + reply(From, Reply), + replies(Replies); +replies([]) -> + ok. + +%% Might actually not send the message in case of caught exception +send(Proc, Msg) -> + try erlang:send(Proc, Msg, [noconnect]) of + noconnect -> + _ = spawn(erlang, send, [Proc,Msg]), + ok; + ok -> + ok + catch + _:_ -> + ok + end. + +%% Here the init_it/6 and enter_loop/5,6,7 functions converge +enter(Module, Opts, State, Data, Server, Actions, Parent) -> + %% The values should already have been type checked + Name = gen:get_proc_name(Server), + Debug = gen:debug_options(Name, Opts), + HibernateAfterTimeout = gen:hibernate_after(Opts), + Events = [], + Event = {internal,init_state}, + %% We enforce {postpone,false} to ensure that + %% our fake Event gets discarded, thought it might get logged + NewActions = listify(Actions) ++ [{postpone,false}], + S = + #state{ + module = Module, + name = Name, + state = State, + data = Data, + hibernate_after = HibernateAfterTimeout}, + CallEnter = true, + NewDebug = ?sys_debug(Debug, {Name,State}, {enter,Event,State}), + case call_callback_mode(S) of + #state{} = NewS -> + loop_event_actions_list( + Parent, NewDebug, NewS, + Events, Event, State, Data, false, + NewActions, CallEnter); + [Class,Reason,Stacktrace] -> + terminate( + Class, Reason, Stacktrace, NewDebug, + S, [Event|Events]) + end. + +%%%========================================================================== +%%% gen callbacks + +init_it(Starter, self, ServerRef, Module, Args, Opts) -> + init_it(Starter, self(), ServerRef, Module, Args, Opts); +init_it(Starter, Parent, ServerRef, Module, Args, Opts) -> + try Module:init(Args) of + Result -> + init_result(Starter, Parent, ServerRef, Module, Result, Opts) + catch + Result -> + init_result(Starter, Parent, ServerRef, Module, Result, Opts); + Class:Reason -> + Stacktrace = erlang:get_stacktrace(), + Name = gen:get_proc_name(ServerRef), + gen:unregister_name(ServerRef), + proc_lib:init_ack(Starter, {error,Reason}), + error_info( + Class, Reason, Stacktrace, + #state{name = Name}, + [], undefined), + erlang:raise(Class, Reason, Stacktrace) + end. + +%%--------------------------------------------------------------------------- +%% gen callbacks helpers + +init_result(Starter, Parent, ServerRef, Module, Result, Opts) -> + case Result of + {ok,State,Data} -> + proc_lib:init_ack(Starter, {ok,self()}), + enter(Module, Opts, State, Data, ServerRef, [], Parent); + {ok,State,Data,Actions} -> + proc_lib:init_ack(Starter, {ok,self()}), + enter(Module, Opts, State, Data, ServerRef, Actions, Parent); + {stop,Reason} -> + gen:unregister_name(ServerRef), + proc_lib:init_ack(Starter, {error,Reason}), + exit(Reason); + ignore -> + gen:unregister_name(ServerRef), + proc_lib:init_ack(Starter, ignore), + exit(normal); + _ -> + Name = gen:get_proc_name(ServerRef), + gen:unregister_name(ServerRef), + Error = {bad_return_from_init,Result}, + proc_lib:init_ack(Starter, {error,Error}), + error_info( + error, Error, ?STACKTRACE(), + #state{name = Name}, + [], undefined), + exit(Error) + end. + +%%%========================================================================== +%%% sys callbacks + +system_continue(Parent, Debug, S) -> + loop(Parent, Debug, S). + +system_terminate(Reason, _Parent, Debug, S) -> + terminate(exit, Reason, ?STACKTRACE(), Debug, S, []). + +system_code_change( + #state{ + module = Module, + state = State, + data = Data} = S, + _Mod, OldVsn, Extra) -> + case + try Module:code_change(OldVsn, State, Data, Extra) + catch + Result -> Result + end + of + {ok,NewState,NewData} -> + {ok, + S#state{ + callback_mode = undefined, + state = NewState, + data = NewData}}; + {ok,_} = Error -> + error({case_clause,Error}); + Error -> + Error + end. + +system_get_state(#state{state = State, data = Data}) -> + {ok,{State,Data}}. + +system_replace_state( + StateFun, + #state{ + state = State, + data = Data} = S) -> + {NewState,NewData} = Result = StateFun({State,Data}), + {ok,Result,S#state{state = NewState, data = NewData}}. + +format_status( + Opt, + [PDict,SysState,Parent,Debug, + #state{name = Name, postponed = P} = S]) -> + Header = gen:format_status_header("Status for state machine", Name), + Log = sys:get_debug(log, Debug, []), + [{header,Header}, + {data, + [{"Status",SysState}, + {"Parent",Parent}, + {"Logged Events",Log}, + {"Postponed",P}]} | + case format_status(Opt, PDict, S) of + L when is_list(L) -> L; + T -> [T] + end]. + +%%--------------------------------------------------------------------------- +%% Format debug messages. Print them as the call-back module sees +%% them, not as the real erlang messages. Use trace for that. +%%--------------------------------------------------------------------------- + +sys_debug(Debug, NameState, Entry) -> + sys:handle_debug(Debug, fun print_event/3, NameState, Entry). + +print_event(Dev, {in,Event}, {Name,State}) -> + io:format( + Dev, "*DBG* ~tp receive ~ts in state ~tp~n", + [Name,event_string(Event),State]); +print_event(Dev, {out,Reply,{To,_Tag}}, {Name,State}) -> + io:format( + Dev, "*DBG* ~tp send ~tp to ~p from state ~tp~n", + [Name,Reply,To,State]); +print_event(Dev, {terminate,Reason}, {Name,State}) -> + io:format( + Dev, "*DBG* ~tp terminate ~tp in state ~tp~n", + [Name,Reason,State]); +print_event(Dev, {Tag,Event,NextState}, {Name,State}) -> + StateString = + case NextState of + State -> + io_lib:format("~tp", [State]); + _ -> + io_lib:format("~tp => ~tp", [State,NextState]) + end, + io:format( + Dev, "*DBG* ~tp ~tw ~ts in state ~ts~n", + [Name,Tag,event_string(Event),StateString]). + +event_string(Event) -> + case Event of + {{call,{Pid,_Tag}},Request} -> + io_lib:format("call ~tp from ~w", [Request,Pid]); + {EventType,EventContent} -> + io_lib:format("~tw ~tp", [EventType,EventContent]) + end. + +%%%========================================================================== +%%% Internal callbacks + +wakeup_from_hibernate(Parent, Debug, S) -> + %% It is a new message that woke us up so we have to receive it now + loop_receive(Parent, Debug, S). + +%%%========================================================================== +%%% State Machine engine implementation of proc_lib/gen server + +%% Server loop, consists of all loop* functions +%% and detours through sys:handle_system_message/7 and proc_lib:hibernate/3 + +%% Entry point for system_continue/3 +loop(Parent, Debug, #state{hibernate = true, cancel_timers = 0} = S) -> + loop_hibernate(Parent, Debug, S); +loop(Parent, Debug, S) -> + loop_receive(Parent, Debug, S). + +loop_hibernate(Parent, Debug, S) -> + %% + %% Does not return but restarts process at + %% wakeup_from_hibernate/3 that jumps to loop_receive/3 + %% + proc_lib:hibernate( + ?MODULE, wakeup_from_hibernate, [Parent,Debug,S]), + error( + {should_not_have_arrived_here_but_instead_in, + {wakeup_from_hibernate,3}}). + +%% Entry point for wakeup_from_hibernate/3 +loop_receive( + Parent, Debug, #state{hibernate_after = HibernateAfterTimeout} = S) -> + %% + receive + Msg -> + case Msg of + {system,Pid,Req} -> + %% Does not return but tail recursively calls + %% system_continue/3 that jumps to loop/3 + sys:handle_system_msg( + Req, Pid, Parent, ?MODULE, Debug, S, + S#state.hibernate); + {'EXIT',Parent,Reason} = EXIT -> + %% EXIT is not a 2-tuple therefore + %% not an event but this will stand out + %% in the crash report... + Q = [EXIT], + terminate(exit, Reason, ?STACKTRACE(), Debug, S, Q); + {timeout,TimerRef,TimerMsg} -> + #state{ + timer_refs = TimerRefs, + timer_types = TimerTypes} = S, + case TimerRefs of + #{TimerRef := TimerType} -> + %% We know of this timer; is it a running + %% timer or a timer being cancelled that + %% managed to send a late timeout message? + case TimerTypes of + #{TimerType := TimerRef} -> + %% The timer type maps back to this + %% timer ref, so it was a running timer + %% Unregister the triggered timeout + NewTimerRefs = + maps:remove(TimerRef, TimerRefs), + NewTimerTypes = + maps:remove(TimerType, TimerTypes), + loop_receive_result( + Parent, Debug, + S#state{ + timer_refs = NewTimerRefs, + timer_types = NewTimerTypes}, + TimerType, TimerMsg); + _ -> + %% This was a late timeout message + %% from timer being cancelled, so + %% ignore it and expect a cancel_timer + %% msg shortly + loop_receive(Parent, Debug, S) + end; + _ -> + %% Not our timer; present it as an event + loop_receive_result(Parent, Debug, S, info, Msg) + end; + {cancel_timer,TimerRef,_} -> + #state{ + timer_refs = TimerRefs, + cancel_timers = CancelTimers, + hibernate = Hibernate} = S, + case TimerRefs of + #{TimerRef := _} -> + %% We must have requested a cancel + %% of this timer so it is already + %% removed from TimerTypes + NewTimerRefs = + maps:remove(TimerRef, TimerRefs), + NewCancelTimers = CancelTimers - 1, + NewS = + S#state{ + timer_refs = NewTimerRefs, + cancel_timers = NewCancelTimers}, + if + Hibernate =:= true, NewCancelTimers =:= 0 -> + %% No more cancel_timer msgs to expect; + %% we can hibernate + loop_hibernate(Parent, Debug, NewS); + NewCancelTimers >= 0 -> % Assert + loop_receive(Parent, Debug, NewS) + end; + _ -> + %% Not our cancel_timer msg; + %% present it as an event + loop_receive_result(Parent, Debug, S, info, Msg) + end; + _ -> + %% External msg + case Msg of + {'$gen_call',From,Request} -> + loop_receive_result( + Parent, Debug, S, {call,From}, Request); + {'$gen_cast',Cast} -> + loop_receive_result(Parent, Debug, S, cast, Cast); + _ -> + loop_receive_result(Parent, Debug, S, info, Msg) + end + end + after + HibernateAfterTimeout -> + loop_hibernate(Parent, Debug, S) + end. + +loop_receive_result(Parent, ?not_sys_debug, S, Type, Content) -> + %% Here is the queue of not yet handled events created + Events = [], + loop_event(Parent, ?not_sys_debug, S, Events, Type, Content); +loop_receive_result( + Parent, Debug, #state{name = Name, state = State} = S, Type, Content) -> + NewDebug = sys_debug(Debug, {Name,State}, {in,{Type,Content}}), + %% Here is the queue of not yet handled events created + Events = [], + loop_event(Parent, NewDebug, S, Events, Type, Content). + +%% Entry point for handling an event, received or enqueued +loop_event( + Parent, Debug, #state{hibernate = Hibernate} = S, + Events, Type, Content) -> + %% + case Hibernate of + true -> + %% + %% If (this old) Hibernate is true here it can only be + %% because it was set from an event action + %% and we did not go into hibernation since there were + %% events in queue, so we do what the user + %% might rely on i.e collect garbage which + %% would have happened if we actually hibernated + %% and immediately was awakened. + %% + _ = garbage_collect(), + loop_event_state_function( + Parent, Debug, S, Events, Type, Content); + false -> + loop_event_state_function( + Parent, Debug, S, Events, Type, Content) + end. + +%% Call the state function +loop_event_state_function( + Parent, Debug, + #state{state = State, data = Data} = S, + Events, Type, Content) -> + %% + %% The field 'hibernate' in S is now invalid and will be + %% restored when looping back to loop/3 or loop_event/6. + %% + Event = {Type,Content}, + TransOpts = false, + case call_state_function(S, Type, Content, State, Data) of + {Result, NewS} -> + loop_event_result( + Parent, Debug, NewS, + Events, Event, State, Data, TransOpts, Result); + [Class,Reason,Stacktrace] -> + terminate( + Class, Reason, Stacktrace, Debug, S, [Event|Events]) + end. + +%% Make a state enter call to the state function +loop_event_state_enter( + Parent, Debug, #state{state = PrevState} = S, + Events, Event, NextState, NewData, TransOpts) -> + %% + case call_state_function(S, enter, PrevState, NextState, NewData) of + {Result, NewS} -> + loop_event_result( + Parent, Debug, NewS, + Events, Event, NextState, NewData, TransOpts, Result); + [Class,Reason,Stacktrace] -> + terminate( + Class, Reason, Stacktrace, Debug, S, [Event|Events]) + end. + +%% Process the result from the state function. +%% When TransOpts =:= false it was a state function call, +%% otherwise it is an option tuple and it was a state enter call. +%% +loop_event_result( + Parent, Debug, S, + Events, Event, State, Data, TransOpts, Result) -> + %% + case Result of + {next_state,State,NewData} -> + loop_event_actions( + Parent, Debug, S, + Events, Event, State, NewData, TransOpts, + [], false); + {next_state,NextState,NewData} + when TransOpts =:= false -> + loop_event_actions( + Parent, Debug, S, + Events, Event, NextState, NewData, TransOpts, + [], true); + {next_state,State,NewData,Actions} -> + loop_event_actions( + Parent, Debug, S, + Events, Event, State, NewData, TransOpts, + Actions, false); + {next_state,NextState,NewData,Actions} + when TransOpts =:= false -> + loop_event_actions( + Parent, Debug, S, + Events, Event, NextState, NewData, TransOpts, + Actions, true); + %% + {keep_state,NewData} -> + loop_event_actions( + Parent, Debug, S, + Events, Event, State, NewData, TransOpts, + [], false); + {keep_state,NewData,Actions} -> + loop_event_actions( + Parent, Debug, S, + Events, Event, State, NewData, TransOpts, + Actions, false); + %% + keep_state_and_data -> + loop_event_actions( + Parent, Debug, S, + Events, Event, State, Data, TransOpts, + [], false); + {keep_state_and_data,Actions} -> + loop_event_actions( + Parent, Debug, S, + Events, Event, State, Data, TransOpts, + Actions, false); + %% + {repeat_state,NewData} -> + loop_event_actions( + Parent, Debug, S, + Events, Event, State, NewData, TransOpts, + [], true); + {repeat_state,NewData,Actions} -> + loop_event_actions( + Parent, Debug, S, + Events, Event, State, NewData, TransOpts, + Actions, true); + %% + repeat_state_and_data -> + loop_event_actions( + Parent, Debug, S, + Events, Event, State, Data, TransOpts, + [], true); + {repeat_state_and_data,Actions} -> + loop_event_actions( + Parent, Debug, S, + Events, Event, State, Data, TransOpts, + Actions, true); + %% + stop -> + terminate( + exit, normal, ?STACKTRACE(), Debug, + S#state{ + state = State, data = Data, + hibernate = hibernate_in_trans_opts(TransOpts)}, + [Event|Events]); + {stop,Reason} -> + terminate( + exit, Reason, ?STACKTRACE(), Debug, + S#state{ + state = State, data = Data, + hibernate = hibernate_in_trans_opts(TransOpts)}, + [Event|Events]); + {stop,Reason,NewData} -> + terminate( + exit, Reason, ?STACKTRACE(), Debug, + S#state{ + state = State, data = NewData, + hibernate = hibernate_in_trans_opts(TransOpts)}, + [Event|Events]); + %% + {stop_and_reply,Reason,Replies} -> + reply_then_terminate( + exit, Reason, ?STACKTRACE(), Debug, + S#state{ + state = State, data = Data, + hibernate = hibernate_in_trans_opts(TransOpts)}, + [Event|Events], Replies); + {stop_and_reply,Reason,Replies,NewData} -> + reply_then_terminate( + exit, Reason, ?STACKTRACE(), Debug, + S#state{ + state = State, data = NewData, + hibernate = hibernate_in_trans_opts(TransOpts)}, + [Event|Events], Replies); + %% + _ -> + terminate( + error, + {bad_return_from_state_function,Result}, + ?STACKTRACE(), Debug, + S#state{ + state = State, data = Data, + hibernate = hibernate_in_trans_opts(TransOpts)}, + [Event|Events]) + end. + +-compile({inline, [hibernate_in_trans_opts/1]}). +hibernate_in_trans_opts(false) -> + (#trans_opts{})#trans_opts.hibernate; +hibernate_in_trans_opts(#trans_opts{hibernate = Hibernate}) -> + Hibernate. + +%% Ensure that Actions are a list +loop_event_actions( + Parent, Debug, S, + Events, Event, NextState, NewerData, TransOpts, + Actions, CallEnter) -> + loop_event_actions_list( + Parent, Debug, S, + Events, Event, NextState, NewerData, TransOpts, + listify(Actions), CallEnter). + +%% Process actions from the state function +loop_event_actions_list( + Parent, Debug, #state{state_enter = StateEnter} = S, + Events, Event, NextState, NewerData, TransOpts, + Actions, CallEnter) -> + %% + case parse_actions(TransOpts, Debug, S, Actions) of + {NewDebug,NewTransOpts} + when StateEnter, CallEnter -> + loop_event_state_enter( + Parent, NewDebug, S, + Events, Event, NextState, NewerData, NewTransOpts); + {NewDebug,NewTransOpts} -> + loop_event_done( + Parent, NewDebug, S, + Events, Event, NextState, NewerData, NewTransOpts); + [Class,Reason,Stacktrace,NewDebug] -> + terminate( + Class, Reason, Stacktrace, NewDebug, + S#state{ + state = NextState, + data = NewerData, + hibernate = TransOpts#trans_opts.hibernate}, + [Event|Events]) + end. + +parse_actions(false, Debug, S, Actions) -> + parse_actions(true, Debug, S, Actions, #trans_opts{}); +parse_actions(TransOpts, Debug, S, Actions) -> + parse_actions(false, Debug, S, Actions, TransOpts). +%% +parse_actions(_StateCall, Debug, _S, [], TransOpts) -> + {Debug,TransOpts}; +parse_actions(StateCall, Debug, S, [Action|Actions], TransOpts) -> + case Action of + %% Actual actions + {reply,From,Reply} -> + parse_actions_reply( + StateCall, Debug, S, Actions, TransOpts, From, Reply); + %% + %% Actions that set options + {hibernate,NewHibernate} when is_boolean(NewHibernate) -> + parse_actions( + StateCall, Debug, S, Actions, + TransOpts#trans_opts{hibernate = NewHibernate}); + hibernate -> + parse_actions( + StateCall, Debug, S, Actions, + TransOpts#trans_opts{hibernate = true}); + %% + {postpone,NewPostpone} when not NewPostpone orelse StateCall -> + parse_actions( + StateCall, Debug, S, Actions, + TransOpts#trans_opts{postpone = NewPostpone}); + postpone when StateCall -> + parse_actions( + StateCall, Debug, S, Actions, + TransOpts#trans_opts{postpone = true}); + %% + {next_event,Type,Content} -> + parse_actions_next_event( + StateCall, Debug, S, Actions, TransOpts, Type, Content); + %% + _ -> + parse_actions_timeout( + StateCall, Debug, S, Actions, TransOpts, Action) + end. + +parse_actions_reply( + StateCall, ?not_sys_debug, S, Actions, TransOpts, + From, Reply) -> + %% + case from(From) of + true -> + reply(From, Reply), + parse_actions(StateCall, ?not_sys_debug, S, Actions, TransOpts); + false -> + [error, + {bad_action_from_state_function,{reply,From,Reply}}, + ?STACKTRACE(), + ?not_sys_debug] + end; +parse_actions_reply( + StateCall, Debug, #state{name = Name, state = State} = S, + Actions, TransOpts, From, Reply) -> + %% + case from(From) of + true -> + reply(From, Reply), + NewDebug = sys_debug(Debug, {Name,State}, {out,Reply,From}), + parse_actions(StateCall, NewDebug, S, Actions, TransOpts); + false -> + [error, + {bad_action_from_state_function,{reply,From,Reply}}, + ?STACKTRACE(), + Debug] + end. + +parse_actions_next_event( + StateCall, ?not_sys_debug, S, + Actions, TransOpts, Type, Content) -> + case event_type(Type) of + true when StateCall -> + NextEventsR = TransOpts#trans_opts.next_events_r, + parse_actions( + StateCall, ?not_sys_debug, S, Actions, + TransOpts#trans_opts{ + next_events_r = [{Type,Content}|NextEventsR]}); + _ -> + [error, + {bad_action_from_state_function,{next_event,Type,Content}}, + ?STACKTRACE(), + ?not_sys_debug] + end; +parse_actions_next_event( + StateCall, Debug, #state{name = Name, state = State} = S, + Actions, TransOpts, Type, Content) -> + case event_type(Type) of + true when StateCall -> + NewDebug = sys_debug(Debug, {Name,State}, {in,{Type,Content}}), + NextEventsR = TransOpts#trans_opts.next_events_r, + parse_actions( + StateCall, NewDebug, S, Actions, + TransOpts#trans_opts{ + next_events_r = [{Type,Content}|NextEventsR]}); + _ -> + [error, + {bad_action_from_state_function,{next_event,Type,Content}}, + ?STACKTRACE(), + Debug] + end. + +parse_actions_timeout( + StateCall, Debug, S, Actions, TransOpts, + {TimerType,Time,TimerMsg,TimerOpts} = AbsoluteTimeout) -> + %% + case classify_timer(Time, listify(TimerOpts)) of + absolute -> + parse_actions_timeout_add( + StateCall, Debug, S, Actions, + TransOpts, AbsoluteTimeout); + relative -> + RelativeTimeout = {TimerType,Time,TimerMsg}, + parse_actions_timeout_add( + StateCall, Debug, S, Actions, + TransOpts, RelativeTimeout); + badarg -> + [error, + {bad_action_from_state_function,AbsoluteTimeout}, + ?STACKTRACE(), + Debug] + end; +parse_actions_timeout( + StateCall, Debug, S, Actions, TransOpts, + {_,Time,_} = RelativeTimeout) -> + case classify_timer(Time, []) of + relative -> + parse_actions_timeout_add( + StateCall, Debug, S, Actions, + TransOpts, RelativeTimeout); + badarg -> + [error, + {bad_action_from_state_function,RelativeTimeout}, + ?STACKTRACE(), + Debug] + end; +parse_actions_timeout( + StateCall, Debug, S, Actions, TransOpts, + Timeout) -> + case classify_timer(Timeout, []) of + relative -> + parse_actions_timeout_add( + StateCall, Debug, S, Actions, TransOpts, Timeout); + badarg -> + [error, + {bad_action_from_state_function,Timeout}, + ?STACKTRACE(), + Debug] + end. + +parse_actions_timeout_add( + StateCall, Debug, S, Actions, + #trans_opts{timeouts_r = TimeoutsR} = TransOpts, Timeout) -> + parse_actions( + StateCall, Debug, S, Actions, + TransOpts#trans_opts{timeouts_r = [Timeout|TimeoutsR]}). + +%% Do the state transition +loop_event_done( + Parent, ?not_sys_debug, + #state{postponed = P} = S, + Events, Event, NextState, NewData, + #trans_opts{ + postpone = Postpone, hibernate = Hibernate, + timeouts_r = [], next_events_r = []}) -> + %% + %% Optimize the simple cases + %% i.e no timer changes, no inserted events and no debug, + %% by duplicate stripped down code + %% + %% Fast path + %% + case Postpone of + true -> + loop_event_done_fast( + Parent, Hibernate, + S, + Events, [Event|P], NextState, NewData); + false -> + loop_event_done_fast( + Parent, Hibernate, + S, + Events, P, NextState, NewData) + end; +loop_event_done( + Parent, Debug_0, + #state{ + state = State, postponed = P_0, + timer_refs = TimerRefs_0, timer_types = TimerTypes_0, + cancel_timers = CancelTimers_0} = S, + Events_0, Event_0, NextState, NewData, + #trans_opts{ + hibernate = Hibernate, timeouts_r = TimeoutsR, + postpone = Postpone, next_events_r = NextEventsR}) -> + %% + %% All options have been collected and next_events are buffered. + %% Do the actual state transition. + %% + %% Full feature path + %% + [Debug_1|P_1] = % Move current event to postponed if Postpone + case Postpone of + true -> + [?sys_debug( + Debug_0, + {S#state.name,State}, + {postpone,Event_0,State}), + Event_0|P_0]; + false -> + [?sys_debug( + Debug_0, + {S#state.name,State}, + {consume,Event_0,State})|P_0] + end, + {Events_2,P_2,Timers_2} = + %% Move all postponed events to queue, + %% cancel the event timer, + %% and cancel the state timeout if the state changes + if + NextState =:= State -> + {Events_0,P_1, + cancel_timer_by_type( + timeout, {TimerTypes_0,CancelTimers_0})}; + true -> + {lists:reverse(P_1, Events_0), + [], + cancel_timer_by_type( + state_timeout, + cancel_timer_by_type( + timeout, {TimerTypes_0,CancelTimers_0}))} + %% The state timer is removed from TimerTypes + %% but remains in TimerRefs until we get + %% the cancel_timer msg + end, + {TimerRefs_3,{TimerTypes_3,CancelTimers_3},TimeoutEvents} = + %% Stop and start timers + parse_timers(TimerRefs_0, Timers_2, TimeoutsR), + %% Place next events last in reversed queue + Events_3R = lists:reverse(Events_2, NextEventsR), + %% Enqueue immediate timeout events + Events_4R = prepend_timeout_events(TimeoutEvents, Events_3R), + loop_event_done( + Parent, Debug_1, + S#state{ + state = NextState, + data = NewData, + postponed = P_2, + timer_refs = TimerRefs_3, + timer_types = TimerTypes_3, + cancel_timers = CancelTimers_3, + hibernate = Hibernate}, + lists:reverse(Events_4R)). + +%% Fast path +%% +loop_event_done_fast( + Parent, Hibernate, + #state{ + state = NextState, + timer_types = #{timeout := _} = TimerTypes, + cancel_timers = CancelTimers} = S, + Events, P, NextState, NewData) -> + %% + %% Same state, event timeout active + %% + loop_event_done_fast( + Parent, Hibernate, S, + Events, P, NextState, NewData, + cancel_timer_by_type( + timeout, {TimerTypes,CancelTimers})); +loop_event_done_fast( + Parent, Hibernate, + #state{state = NextState} = S, + Events, P, NextState, NewData) -> + %% + %% Same state + %% + loop_event_done( + Parent, ?not_sys_debug, + S#state{ + data = NewData, + postponed = P, + hibernate = Hibernate}, + Events); +loop_event_done_fast( + Parent, Hibernate, + #state{ + timer_types = #{timeout := _} = TimerTypes, + cancel_timers = CancelTimers} = S, + Events, P, NextState, NewData) -> + %% + %% State change, event timeout active + %% + loop_event_done_fast( + Parent, Hibernate, S, + lists:reverse(P, Events), [], NextState, NewData, + cancel_timer_by_type( + state_timeout, + cancel_timer_by_type( + timeout, {TimerTypes,CancelTimers}))); +loop_event_done_fast( + Parent, Hibernate, + #state{ + timer_types = #{state_timeout := _} = TimerTypes, + cancel_timers = CancelTimers} = S, + Events, P, NextState, NewData) -> + %% + %% State change, state timeout active + %% + loop_event_done_fast( + Parent, Hibernate, S, + lists:reverse(P, Events), [], NextState, NewData, + cancel_timer_by_type( + state_timeout, + cancel_timer_by_type( + timeout, {TimerTypes,CancelTimers}))); +loop_event_done_fast( + Parent, Hibernate, + #state{} = S, + Events, P, NextState, NewData) -> + %% + %% State change, no timeout to automatically cancel + %% + loop_event_done( + Parent, ?not_sys_debug, + S#state{ + state = NextState, + data = NewData, + postponed = [], + hibernate = Hibernate}, + lists:reverse(P, Events)). +%% +%% Fast path +%% +loop_event_done_fast( + Parent, Hibernate, S, + Events, P, NextState, NewData, + {TimerTypes,CancelTimers}) -> + %% + loop_event_done( + Parent, ?not_sys_debug, + S#state{ + state = NextState, + data = NewData, + postponed = P, + timer_types = TimerTypes, + cancel_timers = CancelTimers, + hibernate = Hibernate}, + Events). + +loop_event_done(Parent, Debug, S, Q) -> + case Q of + [] -> + %% Get a new event + loop(Parent, Debug, S); + [{Type,Content}|Events] -> + %% Loop until out of enqueued events + loop_event(Parent, Debug, S, Events, Type, Content) + end. + + +%%--------------------------------------------------------------------------- +%% Server loop helpers + +call_callback_mode(#state{module = Module} = S) -> + try Module:callback_mode() of + CallbackMode -> + callback_mode_result(S, CallbackMode) + catch + CallbackMode -> + callback_mode_result(S, CallbackMode); + Class:Reason -> + [Class,Reason,erlang:get_stacktrace()] + end. + +callback_mode_result(S, CallbackMode) -> + callback_mode_result( + S, CallbackMode, listify(CallbackMode), undefined, false). +%% +callback_mode_result(_S, CallbackMode, [], undefined, _StateEnter) -> + [error, + {bad_return_from_callback_mode,CallbackMode}, + ?STACKTRACE()]; +callback_mode_result(S, _CallbackMode, [], CBMode, StateEnter) -> + S#state{callback_mode = CBMode, state_enter = StateEnter}; +callback_mode_result(S, CallbackMode, [H|T], CBMode, StateEnter) -> + case callback_mode(H) of + true -> + callback_mode_result(S, CallbackMode, T, H, StateEnter); + false -> + case state_enter(H) of + true -> + callback_mode_result(S, CallbackMode, T, CBMode, true); + false -> + [error, + {bad_return_from_callback_mode,CallbackMode}, + ?STACKTRACE()] + end + end. + + +call_state_function( + #state{callback_mode = undefined} = S, Type, Content, State, Data) -> + case call_callback_mode(S) of + #state{} = NewS -> + call_state_function(NewS, Type, Content, State, Data); + Error -> + Error + end; +call_state_function( + #state{callback_mode = CallbackMode, module = Module} = S, + Type, Content, State, Data) -> + try + case CallbackMode of + state_functions -> + Module:State(Type, Content, Data); + handle_event_function -> + Module:handle_event(Type, Content, State, Data) + end + of + Result -> + {Result,S} + catch + Result -> + {Result,S}; + Class:Reason -> + [Class,Reason,erlang:get_stacktrace()] + end. + + +%% -> absolute | relative | badarg +classify_timer(Time, Opts) -> + classify_timer(Time, Opts, false). +%% +classify_timer(Time, [], Abs) -> + case Abs of + true when + is_integer(Time); + Time =:= infinity -> + absolute; + false when + is_integer(Time), 0 =< Time; + Time =:= infinity -> + relative; + _ -> + badarg + end; +classify_timer(Time, [{abs,Abs}|Opts], _) when is_boolean(Abs) -> + classify_timer(Time, Opts, Abs); +classify_timer(_, Opts, _) when is_list(Opts) -> + badarg. + +%% Stop and start timers as well as create timeout zero events +%% and pending event timer +%% +%% Stop and start timers non-event timers +parse_timers(TimerRefs, Timers, TimeoutsR) -> + parse_timers(TimerRefs, Timers, TimeoutsR, #{}, []). +%% +parse_timers( + TimerRefs, Timers, [], _Seen, TimeoutEvents) -> + %% + {TimerRefs,Timers,TimeoutEvents}; +parse_timers( + TimerRefs, Timers, [Timeout|TimeoutsR], Seen, TimeoutEvents) -> + %% + case Timeout of + {TimerType,Time,TimerMsg,TimerOpts} -> + %% Absolute timer + parse_timers( + TimerRefs, Timers, TimeoutsR, Seen, TimeoutEvents, + TimerType, Time, TimerMsg, listify(TimerOpts)); + %% Relative timers below + {TimerType,0,TimerMsg} -> + parse_timers( + TimerRefs, Timers, TimeoutsR, Seen, TimeoutEvents, + TimerType, zero, TimerMsg, []); + {TimerType,Time,TimerMsg} -> + parse_timers( + TimerRefs, Timers, TimeoutsR, Seen, TimeoutEvents, + TimerType, Time, TimerMsg, []); + 0 -> + parse_timers( + TimerRefs, Timers, TimeoutsR, Seen, TimeoutEvents, + timeout, zero, 0, []); + Time -> + parse_timers( + TimerRefs, Timers, TimeoutsR, Seen, TimeoutEvents, + timeout, Time, Time, []) + end. + +parse_timers( + TimerRefs, Timers, TimeoutsR, Seen, TimeoutEvents, + TimerType, Time, TimerMsg, TimerOpts) -> + case Seen of + #{TimerType := _} -> + %% Type seen before - ignore + parse_timers( + TimerRefs, Timers, TimeoutsR, Seen, TimeoutEvents); + #{} -> + %% Unseen type - handle + NewSeen = Seen#{TimerType => true}, + case Time of + infinity -> + %% Cancel any running timer + parse_timers( + TimerRefs, cancel_timer_by_type(TimerType, Timers), + TimeoutsR, NewSeen, TimeoutEvents); + zero -> + %% Cancel any running timer + %% Handle zero time timeouts later + parse_timers( + TimerRefs, cancel_timer_by_type(TimerType, Timers), + TimeoutsR, NewSeen, + [{TimerType,TimerMsg}|TimeoutEvents]); + _ -> + %% (Re)start the timer + TimerRef = + erlang:start_timer( + Time, self(), TimerMsg, TimerOpts), + case Timers of + {#{TimerType := OldTimerRef} = TimerTypes, + CancelTimers} -> + %% Cancel the running timer + cancel_timer(OldTimerRef), + NewCancelTimers = CancelTimers + 1, + %% Insert the new timer into + %% both TimerRefs and TimerTypes + parse_timers( + TimerRefs#{TimerRef => TimerType}, + {TimerTypes#{TimerType => TimerRef}, + NewCancelTimers}, + TimeoutsR, NewSeen, TimeoutEvents); + {#{} = TimerTypes,CancelTimers} -> + %% Insert the new timer into + %% both TimerRefs and TimerTypes + parse_timers( + TimerRefs#{TimerRef => TimerType}, + {TimerTypes#{TimerType => TimerRef}, + CancelTimers}, + TimeoutsR, NewSeen, TimeoutEvents) + end + end + end. + +%% Enqueue immediate timeout events (timeout 0 events) +%% +%% Event timer timeout 0 events gets special treatment since +%% an event timer is cancelled by any received event, +%% so if there are enqueued events before the event timer +%% timeout 0 event - the event timer is cancelled hence no event. +%% +%% Other (state_timeout) timeout 0 events that are after +%% the event timer timeout 0 events are considered to +%% belong to timers that were started after the event timer +%% timeout 0 event fired, so they do not cancel the event timer. +%% +prepend_timeout_events([], EventsR) -> + EventsR; +prepend_timeout_events([{timeout,_} = TimeoutEvent|TimeoutEvents], []) -> + prepend_timeout_events(TimeoutEvents, [TimeoutEvent]); +prepend_timeout_events([{timeout,_}|TimeoutEvents], EventsR) -> + %% Ignore since there are other events in queue + %% so they have cancelled the event timeout 0. + prepend_timeout_events(TimeoutEvents, EventsR); +prepend_timeout_events([TimeoutEvent|TimeoutEvents], EventsR) -> + %% Just prepend all others + prepend_timeout_events(TimeoutEvents, [TimeoutEvent|EventsR]). + + + +%%--------------------------------------------------------------------------- +%% Server helpers + +reply_then_terminate(Class, Reason, Stacktrace, Debug, S, Q, Replies) -> + do_reply_then_terminate( + Class, Reason, Stacktrace, Debug, S, Q, listify(Replies)). +%% +do_reply_then_terminate( + Class, Reason, Stacktrace, Debug, S, Q, []) -> + terminate(Class, Reason, Stacktrace, Debug, S, Q); +do_reply_then_terminate( + Class, Reason, Stacktrace, Debug, S, Q, [R|Rs]) -> + case R of + {reply,{_To,_Tag}=From,Reply} -> + reply(From, Reply), + NewDebug = + ?sys_debug( + Debug, + begin + #state{name = Name, state = State} = S, + {Name,State} + end, + {out,Reply,From}), + do_reply_then_terminate( + Class, Reason, Stacktrace, NewDebug, S, Q, Rs); + _ -> + terminate( + error, + {bad_reply_action_from_state_function,R}, + ?STACKTRACE(), + Debug, S, Q) + end. + +terminate( + Class, Reason, Stacktrace, Debug, + #state{module = Module, state = State, data = Data} = S, + Q) -> + case erlang:function_exported(Module, terminate, 3) of + true -> + try Module:terminate(Reason, State, Data) of + _ -> ok + catch + _ -> ok; + C:R -> + ST = erlang:get_stacktrace(), + error_info( + C, R, ST, S, Q, + format_status(terminate, get(), S)), + sys:print_log(Debug), + erlang:raise(C, R, ST) + end; + false -> + ok + end, + _ = + case Reason of + normal -> + terminate_sys_debug(Debug, S, State, Reason); + shutdown -> + terminate_sys_debug(Debug, S, State, Reason); + {shutdown,_} -> + terminate_sys_debug(Debug, S, State, Reason); + _ -> + error_info( + Class, Reason, Stacktrace, S, Q, + format_status(terminate, get(), S)), + sys:print_log(Debug) + end, + case Stacktrace of + [] -> + erlang:Class(Reason); + _ -> + erlang:raise(Class, Reason, Stacktrace) + end. + +terminate_sys_debug(Debug, S, State, Reason) -> + ?sys_debug(Debug, {S#state.name,State}, {terminate,Reason}). + + +error_info( + Class, Reason, Stacktrace, + #state{ + name = Name, + callback_mode = CallbackMode, + state_enter = StateEnter, + postponed = P}, + Q, FmtData) -> + {FixedReason,FixedStacktrace} = + case Stacktrace of + [{M,F,Args,_}|ST] + when Class =:= error, Reason =:= undef -> + case code:is_loaded(M) of + false -> + {{'module could not be loaded',M},ST}; + _ -> + Arity = + if + is_list(Args) -> + length(Args); + is_integer(Args) -> + Args + end, + case erlang:function_exported(M, F, Arity) of + true -> + {Reason,Stacktrace}; + false -> + {{'function not exported',{M,F,Arity}}, + ST} + end + end; + _ -> {Reason,Stacktrace} + end, + [LimitedP, LimitedFmtData, LimitedFixedReason] = + [error_logger:limit_term(D) || D <- [P, FmtData, FixedReason]], + CBMode = + case StateEnter of + true -> + [CallbackMode,state_enter]; + false -> + CallbackMode + end, + error_logger:format( + "** State machine ~tp terminating~n" ++ + case Q of + [] -> ""; + _ -> "** Last event = ~tp~n" + end ++ + "** When server state = ~tp~n" ++ + "** Reason for termination = ~w:~tp~n" ++ + "** Callback mode = ~p~n" ++ + case Q of + [_,_|_] -> "** Queued = ~tp~n"; + _ -> "" + end ++ + case P of + [] -> ""; + _ -> "** Postponed = ~tp~n" + end ++ + case FixedStacktrace of + [] -> ""; + _ -> "** Stacktrace =~n** ~tp~n" + end, + [Name | + case Q of + [] -> []; + [Event|_] -> [Event] + end] ++ + [LimitedFmtData, + Class,LimitedFixedReason, + CBMode] ++ + case Q of + [_|[_|_] = Events] -> [Events]; + _ -> [] + end ++ + case P of + [] -> []; + _ -> [LimitedP] + end ++ + case FixedStacktrace of + [] -> []; + _ -> [FixedStacktrace] + end). + + +%% Call Module:format_status/2 or return a default value +format_status( + Opt, PDict, + #state{module = Module, state = State, data = Data}) -> + case erlang:function_exported(Module, format_status, 2) of + true -> + try Module:format_status(Opt, [PDict,State,Data]) + catch + Result -> Result; + _:_ -> + format_status_default( + Opt, State, + atom_to_list(Module) ++ ":format_status/2 crashed") + end; + false -> + format_status_default(Opt, State, Data) + end. + +%% The default Module:format_status/2 +format_status_default(Opt, State, Data) -> + StateData = {State,Data}, + case Opt of + terminate -> + StateData; + _ -> + [{data,[{"State",StateData}]}] + end. + +-compile({inline, [listify/1]}). +listify(Item) when is_list(Item) -> + Item; +listify(Item) -> + [Item]. + +%% Cancel timer if running, otherwise no op +%% +%% This is an asynchronous cancel so the timer is not really cancelled +%% until we get a cancel_timer msg i.e {cancel_timer,TimerRef,_}. +%% In the mean time we might get a timeout message. +%% +%% Remove the timer from TimerTypes. +%% When we get the cancel_timer msg we remove it from TimerRefs. +-compile({inline, [cancel_timer_by_type/2]}). +cancel_timer_by_type(TimerType, {TimerTypes,CancelTimers} = TT_CT) -> + case TimerTypes of + #{TimerType := TimerRef} -> + ok = erlang:cancel_timer(TimerRef, [{async,true}]), + {maps:remove(TimerType, TimerTypes),CancelTimers + 1}; + #{} -> + TT_CT + end. + +-compile({inline, [cancel_timer/1]}). +cancel_timer(TimerRef) -> + ok = erlang:cancel_timer(TimerRef, [{async,true}]). diff --git a/lib/stdlib/src/io.erl b/lib/stdlib/src/io.erl index 284f2e5a2b..f510f61e9f 100644 --- a/lib/stdlib/src/io.erl +++ b/lib/stdlib/src/io.erl @@ -444,7 +444,7 @@ scan_erl_form(Io, Prompt, Pos0, Options) -> %% Parsing Erlang code. -type parse_ret() :: {'ok', - ExprList :: erl_parse:abstract_expr(), + ExprList :: [erl_parse:abstract_expr()], EndLocation :: location()} | {'eof', EndLocation :: location()} | {'error', @@ -631,41 +631,20 @@ io_requests(Pid, [], [Rs|Cont], Tail) -> io_requests(_Pid, [], [], _Tail) -> {false,[]}. - -bc_req(Pid,{Op,Enc,Param},MaybeConvert) -> - case net_kernel:dflag_unicode_io(Pid) of - true -> - {false,{Op,Enc,Param}}; - false -> - {MaybeConvert,{Op,Param}} - end; -bc_req(Pid,{Op,Enc,P,F},MaybeConvert) -> - case net_kernel:dflag_unicode_io(Pid) of - true -> - {false,{Op,Enc,P,F}}; - false -> - {MaybeConvert,{Op,P,F}} - end; -bc_req(Pid, {Op,Enc,M,F,A},MaybeConvert) -> +bc_req(Pid, Req0, MaybeConvert) -> case net_kernel:dflag_unicode_io(Pid) of true -> - {false,{Op,Enc,M,F,A}}; + %% The most common case. A modern i/o server. + {false,Req0}; false -> - {MaybeConvert,{Op,M,F,A}} - end; -bc_req(Pid, {Op,Enc,P,M,F,A},MaybeConvert) -> - case net_kernel:dflag_unicode_io(Pid) of - true -> - {false,{Op,Enc,P,M,F,A}}; - false -> - {MaybeConvert,{Op,P,M,F,A}} - end; -bc_req(Pid,{Op,Enc},MaybeConvert) -> - case net_kernel:dflag_unicode_io(Pid) of - true -> - {false,{Op, Enc}}; - false -> - {MaybeConvert,Op} + %% Backward compatibility only. Unlikely to ever happen. + case tuple_to_list(Req0) of + [Op,_Enc] -> + {MaybeConvert,Op}; + [Op,_Enc|T] -> + Req = list_to_tuple([Op|T]), + {MaybeConvert,Req} + end end. io_request(Pid, {write,Term}) -> diff --git a/lib/stdlib/src/io_lib.erl b/lib/stdlib/src/io_lib.erl index ef30f16f18..50bf959db5 100644 --- a/lib/stdlib/src/io_lib.erl +++ b/lib/stdlib/src/io_lib.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2014. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -28,7 +28,7 @@ %% Most of the code here is derived from the original prolog versions and %% from similar code written by Joe Armstrong and myself. %% -%% This module has been split into seperate modules: +%% This module has been split into separate modules: %% io_lib - basic write and utilities %% io_lib_format - formatted output %% io_lib_fread - formatted input @@ -68,8 +68,8 @@ -export([write_atom/1,write_string/1,write_string/2,write_latin1_string/1, write_latin1_string/2, write_char/1, write_latin1_char/1]). --export([write_string_as_latin1/1, write_string_as_latin1/2, - write_char_as_latin1/1]). +-export([write_atom_as_latin1/1, write_string_as_latin1/1, + write_string_as_latin1/2, write_char_as_latin1/1]). -export([quote_atom/2, char_list/1, latin1_char_list/1, deep_char_list/1, deep_latin1_char_list/1, @@ -84,6 +84,8 @@ -export([write_unicode_string/1, write_unicode_char/1, deep_unicode_char_list/1]). +-export([limit_term/2]). + -export_type([chars/0, latin1_string/0, continuation/0, fread_error/0, fread_item/0, format_spec/0]). @@ -112,14 +114,14 @@ -type format_spec() :: #{ - control_char => char(), - args => [any()], - width => 'none' | integer(), - adjust => 'left' | 'right', - precision => 'none' | integer(), - pad_char => char(), - encoding => 'unicode' | 'latin1', - strings => boolean() + control_char := char(), + args := [any()], + width := 'none' | integer(), + adjust := 'left' | 'right', + precision := 'none' | integer(), + pad_char := char(), + encoding := 'unicode' | 'latin1', + strings := boolean() }. %%---------------------------------------------------------------------- @@ -147,7 +149,7 @@ fread(Chars, Format) -> -spec fread(Continuation, CharSpec, Format) -> Return when Continuation :: continuation() | [], - CharSpec :: string() | eof, + CharSpec :: string() | 'eof', Format :: string(), Return :: {'more', Continuation1 :: continuation()} | {'done', Result, LeftOverChars :: string()}, @@ -268,47 +270,61 @@ write(Term, D, false) -> -spec write(Term, Depth) -> chars() when Term :: term(), + Depth :: depth(); + (Term, Options) -> chars() when + Term :: term(), + Options :: [Option], + Option :: {'depth', Depth} + | {'encoding', 'latin1' | 'utf8' | 'unicode'}, Depth :: depth(). -write(_Term, 0) -> "..."; -write(Term, _D) when is_integer(Term) -> integer_to_list(Term); -write(Term, _D) when is_float(Term) -> io_lib_format:fwrite_g(Term); -write(Atom, _D) when is_atom(Atom) -> write_atom(Atom); -write(Term, _D) when is_port(Term) -> write_port(Term); -write(Term, _D) when is_pid(Term) -> pid_to_list(Term); -write(Term, _D) when is_reference(Term) -> write_ref(Term); -write(<<_/bitstring>>=Term, D) -> write_binary(Term, D); -write([], _D) -> "[]"; -write({}, _D) -> "{}"; -write([H|T], D) -> +write(Term, Options) when is_list(Options) -> + Depth = get_option(depth, Options, -1), + Encoding = get_option(encoding, Options, epp:default_encoding()), + write1(Term, Depth, Encoding); +write(Term, Depth) -> + write1(Term, Depth, latin1). + +write1(_Term, 0, _E) -> "..."; +write1(Term, _D, _E) when is_integer(Term) -> integer_to_list(Term); +write1(Term, _D, _E) when is_float(Term) -> io_lib_format:fwrite_g(Term); +write1(Atom, _D, latin1) when is_atom(Atom) -> write_atom_as_latin1(Atom); +write1(Atom, _D, _E) when is_atom(Atom) -> write_atom(Atom); +write1(Term, _D, _E) when is_port(Term) -> write_port(Term); +write1(Term, _D, _E) when is_pid(Term) -> pid_to_list(Term); +write1(Term, _D, _E) when is_reference(Term) -> write_ref(Term); +write1(<<_/bitstring>>=Term, D, _E) -> write_binary(Term, D); +write1([], _D, _E) -> "[]"; +write1({}, _D, _E) -> "{}"; +write1([H|T], D, E) -> if D =:= 1 -> "[...]"; true -> - [$[,[write(H, D-1)|write_tail(T, D-1, $|)],$]] + [$[,[write1(H, D-1, E)|write_tail(T, D-1, E, $|)],$]] end; -write(F, _D) when is_function(F) -> +write1(F, _D, _E) when is_function(F) -> erlang:fun_to_list(F); -write(Term, D) when is_map(Term) -> - write_map(Term, D); -write(T, D) when is_tuple(T) -> +write1(Term, D, E) when is_map(Term) -> + write_map(Term, D, E); +write1(T, D, E) when is_tuple(T) -> if D =:= 1 -> "{...}"; true -> [${, - [write(element(1, T), D-1)| - write_tail(tl(tuple_to_list(T)), D-1, $,)], + [write1(element(1, T), D-1, E)| + write_tail(tl(tuple_to_list(T)), D-1, E, $,)], $}] end. %% write_tail(List, Depth, CharacterBeforeDots) %% Test the terminating case first as this looks better with depth. -write_tail([], _D, _S) -> ""; -write_tail(_, 1, S) -> [S | "..."]; -write_tail([H|T], D, S) -> - [$,,write(H, D-1)|write_tail(T, D-1, S)]; -write_tail(Other, D, S) -> - [S,write(Other, D-1)]. +write_tail([], _D, _E, _S) -> ""; +write_tail(_, 1, _E, S) -> [S | "..."]; +write_tail([H|T], D, E, S) -> + [$,,write1(H, D-1, E)|write_tail(T, D-1, E, S)]; +write_tail(Other, D, E, S) -> + [S,write1(Other, D-1, E)]. write_port(Port) -> erlang:port_to_list(Port). @@ -316,17 +332,17 @@ write_port(Port) -> write_ref(Ref) -> erlang:ref_to_list(Ref). -write_map(Map, D) when is_integer(D) -> - [$#,${,write_map_body(maps:to_list(Map), D),$}]. +write_map(Map, D, E) when is_integer(D) -> + [$#,${,write_map_body(maps:to_list(Map), D, E),$}]. -write_map_body(_, 0) -> "..."; -write_map_body([],_) -> []; -write_map_body([{K,V}],D) -> write_map_assoc(K,V,D); -write_map_body([{K,V}|KVs], D) -> - [write_map_assoc(K,V,D),$, | write_map_body(KVs,D-1)]. +write_map_body(_, 0, _E) -> "..."; +write_map_body([], _, _E) -> []; +write_map_body([{K,V}], D, E) -> write_map_assoc(K, V, D, E); +write_map_body([{K,V}|KVs], D, E) -> + [write_map_assoc(K, V, D, E),$, | write_map_body(KVs, D-1, E)]. -write_map_assoc(K,V,D) -> - [write(K,D - 1),"=>",write(V,D-1)]. +write_map_assoc(K, V, D, E) -> + [write1(K, D - 1, E),"=>",write1(V, D-1, E)]. write_binary(B, D) when is_integer(D) -> [$<,$<,write_binary_body(B, D),$>,$>]. @@ -344,6 +360,18 @@ write_binary_body(B, _D) -> <<X:L>> = B, [integer_to_list(X),$:,integer_to_list(L)]. +get_option(Key, TupleList, Default) -> + case lists:keyfind(Key, 1, TupleList) of + false -> Default; + {Key, Value} -> Value; + _ -> Default + end. + +%%% There are two functions to write Unicode atoms: +%%% - they both escape control characters < 160; +%%% - write_atom() never escapes characters >= 160; +%%% - write_atom_as_latin1() also escapes characters >= 255. + %% write_atom(Atom) -> [Char] %% Generate the list of characters needed to print an atom. @@ -351,17 +379,26 @@ write_binary_body(B, _D) -> Atom :: atom(). write_atom(Atom) -> + write_possibly_quoted_atom(Atom, fun write_string/2). + +-spec write_atom_as_latin1(Atom) -> latin1_string() when + Atom :: atom(). + +write_atom_as_latin1(Atom) -> + write_possibly_quoted_atom(Atom, fun write_string_as_latin1/2). + +write_possibly_quoted_atom(Atom, PFun) -> Chars = atom_to_list(Atom), case quote_atom(Atom, Chars) of true -> - write_string(Chars, $'); %' + PFun(Chars, $'); %' false -> Chars end. %% quote_atom(Atom, CharList) %% Return 'true' if atom with chars in CharList needs to be quoted, else -%% return 'false'. +%% return 'false'. Notice that characters >= 160 are always quoted. -spec quote_atom(atom(), chars()) -> boolean(). @@ -876,3 +913,116 @@ binrev(L) -> binrev(L, T) -> list_to_binary(lists:reverse(L, T)). + +-spec limit_term(term(), non_neg_integer()) -> term(). + +%% The intention is to mimic the depth limitation of io_lib:write() +%% and io_lib_pretty:print(). The leaves ('...') should never be +%% seen when printed with the same depth. Bitstrings are never +%% truncated, which is OK as long as they are not sent to other nodes. +limit_term(Term, Depth) -> + try test_limit(Term, Depth) of + ok -> Term + catch + throw:limit -> + limit(Term, Depth) + end. + +limit(_, 0) -> '...'; +limit([H|T]=L, D) -> + if + D =:= 1 -> '...'; + true -> + case printable_list(L) of + true -> L; + false -> + [limit(H, D-1)|limit_tail(T, D-1)] + end + end; +limit(Term, D) when is_map(Term) -> + limit_map(Term, D); +limit({}=T, _D) -> T; +limit(T, D) when is_tuple(T) -> + if + D =:= 1 -> '...'; + true -> + list_to_tuple([limit(element(1, T), D-1)| + limit_tail(tl(tuple_to_list(T)), D-1)]) + end; +limit(<<_/bitstring>>=Term, D) -> limit_bitstring(Term, D); +limit(Term, _D) -> Term. + +limit_tail([], _D) -> []; +limit_tail(_, 1) -> ['...']; +limit_tail([H|T], D) -> + [limit(H, D-1)|limit_tail(T, D-1)]; +limit_tail(Other, D) -> + limit(Other, D-1). + +%% Cannot limit maps properly since there is no guarantee that +%% maps:from_list() creates a map with the same internal ordering of +%% the selected associations as in Map. +limit_map(Map, D) -> + maps:from_list(erts_internal:maps_to_list(Map, D)). +%% maps:from_list(limit_map_body(erts_internal:maps_to_list(Map, D), D)). + +%% limit_map_body(_, 0) -> [{'...', '...'}]; +%% limit_map_body([], _) -> []; +%% limit_map_body([{K,V}], D) -> [limit_map_assoc(K, V, D)]; +%% limit_map_body([{K,V}|KVs], D) -> +%% [limit_map_assoc(K, V, D) | limit_map_body(KVs, D-1)]. + +%% limit_map_assoc(K, V, D) -> +%% {limit(K, D-1), limit(V, D-1)}. + +limit_bitstring(B, _D) -> B. %% Keeps all printable binaries. + +test_limit(_, 0) -> throw(limit); +test_limit([H|T]=L, D) when is_integer(D) -> + if + D =:= 1 -> throw(limit); + true -> + case printable_list(L) of + true -> ok; + false -> + test_limit(H, D-1), + test_limit_tail(T, D-1) + end + end; +test_limit(Term, D) when is_map(Term) -> + test_limit_map(Term, D); +test_limit({}, _D) -> ok; +test_limit(T, D) when is_tuple(T) -> + test_limit_tuple(T, 1, tuple_size(T), D); +test_limit(<<_/bitstring>>=Term, D) -> test_limit_bitstring(Term, D); +test_limit(_Term, _D) -> ok. + +test_limit_tail([], _D) -> ok; +test_limit_tail(_, 1) -> throw(limit); +test_limit_tail([H|T], D) -> + test_limit(H, D-1), + test_limit_tail(T, D-1); +test_limit_tail(Other, D) -> + test_limit(Other, D-1). + +test_limit_tuple(_T, I, Sz, _D) when I > Sz -> ok; +test_limit_tuple(_, _, _, 1) -> throw(limit); +test_limit_tuple(T, I, Sz, D) -> + test_limit(element(I, T), D-1), + test_limit_tuple(T, I+1, Sz, D-1). + +test_limit_map(_Map, _D) -> ok. +%% test_limit_map_body(erts_internal:maps_to_list(Map, D), D). + +%% test_limit_map_body(_, 0) -> throw(limit); +%% test_limit_map_body([], _) -> ok; +%% test_limit_map_body([{K,V}], D) -> test_limit_map_assoc(K, V, D); +%% test_limit_map_body([{K,V}|KVs], D) -> +%% test_limit_map_assoc(K, V, D), +%% test_limit_map_body(KVs, D-1). + +%% test_limit_map_assoc(K, V, D) -> +%% test_limit(K, D-1), +%% test_limit(V, D-1). + +test_limit_bitstring(_, _) -> ok. diff --git a/lib/stdlib/src/io_lib_format.erl b/lib/stdlib/src/io_lib_format.erl index 282005da7d..4b2d15c8b3 100644 --- a/lib/stdlib/src/io_lib_format.erl +++ b/lib/stdlib/src/io_lib_format.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2014. All Rights Reserved. +%% Copyright Ericsson AB 1996-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -257,15 +257,18 @@ indentation([], I) -> I. %% This is the main dispatch function for the various formatting commands. %% Field widths and precisions have already been calculated. -control($w, [A], F, Adj, P, Pad, _Enc, _Str, _I) -> - term(io_lib:write(A, -1), F, Adj, P, Pad); +control($w, [A], F, Adj, P, Pad, Enc, _Str, _I) -> + term(io_lib:write(A, [{depth,-1}, {encoding, Enc}]), F, Adj, P, Pad); control($p, [A], F, Adj, P, Pad, Enc, Str, I) -> print(A, -1, F, Adj, P, Pad, Enc, Str, I); -control($W, [A,Depth], F, Adj, P, Pad, _Enc, _Str, _I) when is_integer(Depth) -> - term(io_lib:write(A, Depth), F, Adj, P, Pad); +control($W, [A,Depth], F, Adj, P, Pad, Enc, _Str, _I) when is_integer(Depth) -> + term(io_lib:write(A, [{depth,Depth}, {encoding, Enc}]), F, Adj, P, Pad); control($P, [A,Depth], F, Adj, P, Pad, Enc, Str, I) when is_integer(Depth) -> print(A, Depth, F, Adj, P, Pad, Enc, Str, I); -control($s, [A], F, Adj, P, Pad, _Enc, _Str, _I) when is_atom(A) -> +control($s, [A], F, Adj, P, Pad, latin1, _Str, _I) when is_atom(A) -> + L = iolist_to_chars(atom_to_list(A)), + string(L, F, Adj, P, Pad); +control($s, [A], F, Adj, P, Pad, unicode, _Str, _I) when is_atom(A) -> string(atom_to_list(A), F, Adj, P, Pad); control($s, [L0], F, Adj, P, Pad, latin1, _Str, _I) -> L = iolist_to_chars(L0), @@ -332,7 +335,7 @@ base(B) when is_integer(B) -> term(T, none, _Adj, none, _Pad) -> T; term(T, none, Adj, P, Pad) -> term(T, P, Adj, P, Pad); term(T, F, Adj, P0, Pad) -> - L = lists:flatlength(T), + L = string:length(T), P = erlang:min(L, case P0 of none -> F; _ -> min(P0, F) end), if L > P -> @@ -343,7 +346,8 @@ term(T, F, Adj, P0, Pad) -> %% print(Term, Depth, Field, Adjust, Precision, PadChar, Encoding, %% Indentation) -%% Print a term. +%% Print a term. Field width sets maximum line length, Precision sets +%% initial indentation. print(T, D, none, Adj, P, Pad, E, Str, I) -> print(T, D, 80, Adj, P, Pad, E, Str, I); @@ -671,11 +675,11 @@ cdata_to_chars(B) when is_binary(B) -> string(S, none, _Adj, none, _Pad) -> S; string(S, F, Adj, none, Pad) -> - string_field(S, F, Adj, lists:flatlength(S), Pad); + string_field(S, F, Adj, string:length(S), Pad); string(S, none, _Adj, P, Pad) -> - string_field(S, P, left, lists:flatlength(S), Pad); + string_field(S, P, left, string:length(S), Pad); string(S, F, Adj, P, Pad) when F >= P -> - N = lists:flatlength(S), + N = string:length(S), if F > P -> if N > P -> adjust(flat_trunc(S, P), chars(Pad, F-P), Adj); @@ -745,18 +749,7 @@ adjust(Data, Pad, right) -> [Pad|Data]. %% Flatten and truncate a deep list to at most N elements. flat_trunc(List, N) when is_integer(N), N >= 0 -> - flat_trunc(List, N, [], []). - -flat_trunc(L, 0, _, R) when is_list(L) -> - lists:reverse(R); -flat_trunc([H|T], N, S, R) when is_list(H) -> - flat_trunc(H, N, [T|S], R); -flat_trunc([H|T], N, S, R) -> - flat_trunc(T, N-1, S, [H|R]); -flat_trunc([], N, [H|S], R) -> - flat_trunc(H, N, S, R); -flat_trunc([], _, [], R) -> - lists:reverse(R). + string:slice(List, 0, N). %% A deep version of string:chars/2,3 diff --git a/lib/stdlib/src/io_lib_fread.erl b/lib/stdlib/src/io_lib_fread.erl index 25555c6f52..319bff484e 100644 --- a/lib/stdlib/src/io_lib_fread.erl +++ b/lib/stdlib/src/io_lib_fread.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2013. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -38,7 +38,7 @@ -spec fread(Continuation, String, Format) -> Return when Continuation :: io_lib:continuation() | [], - String :: string(), + String :: string() | 'eof', Format :: string(), Return :: {'more', Continuation1 :: io_lib:continuation()} | {'done', Result, LeftOverChars :: string()}, @@ -159,8 +159,8 @@ fread_field([$t|Format], F, Sup, _Unic) -> fread_field(Format, F, Sup, Unic) -> {Format,F,Sup,Unic}. -%% fread1(Format, FieldWidth, Suppress, Line, N, Results, AllFormat) -%% fread1(Format, FieldWidth, Suppress, Line, N, Results) +%% fread1(Format, FieldWidth, Suppress, Unicode, Line, N, Results, AllFormat) +%% fread1(Format, FieldWidth, Suppress, Unicode, Line, N, Results) %% The main dispatch function for the formatting commands. Done in two %% stages so format commands that need no input can always be processed. @@ -231,9 +231,8 @@ fread1([$s|Format], none, Sup, U, Line0, N0, Res) -> fread1([$s|Format], F, Sup, U, Line0, N, Res) -> {Line,Cs} = fread_chars(Line0, F, U), fread_string(Cs, Sup, U, Format, Line, N+F, Res); -%% XXX:PaN Atoms still only latin1... -fread1([$a|Format], none, Sup, false, Line0, N0, Res) -> - {Line,N,Cs} = fread_string_cs(Line0, N0, false), +fread1([$a|Format], none, Sup, U, Line0, N0, Res) -> + {Line,N,Cs} = fread_string_cs(Line0, N0, U), fread_atom(Cs, Sup, Format, Line, N, Res); fread1([$a|Format], F, Sup, false, Line0, N, Res) -> {Line,Cs} = fread_chars(Line0, F, false), diff --git a/lib/stdlib/src/io_lib_pretty.erl b/lib/stdlib/src/io_lib_pretty.erl index 6309addf57..505613b80e 100644 --- a/lib/stdlib/src/io_lib_pretty.erl +++ b/lib/stdlib/src/io_lib_pretty.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2013. All Rights Reserved. +%% Copyright Ericsson AB 1996-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -97,37 +97,54 @@ print(Term, Col, Ll, D, RecDefFun) -> print(Term, Col, Ll, D, M, RecDefFun) -> print(Term, Col, Ll, D, M, RecDefFun, latin1, true). +%% D = Depth, default -1 (infinite), or LINEMAX=30 when printing from shell +%% Col = current column, default 1 +%% Ll = line length/~p field width, default 80 +%% M = CHAR_MAX (-1 if no max, 60 when printing from shell) print(_, _, _, 0, _M, _RF, _Enc, _Str) -> "..."; print(Term, Col, Ll, D, M, RecDefFun, Enc, Str) when Col =< 0 -> + %% ensure Col is at least 1 print(Term, 1, Ll, D, M, RecDefFun, Enc, Str); +print(Atom, _Col, _Ll, _D, _M, _RF, Enc, _Str) when is_atom(Atom) -> + write_atom(Atom, Enc); print(Term, Col, Ll, D, M0, RecDefFun, Enc, Str) when is_tuple(Term); is_list(Term); is_map(Term); is_bitstring(Term) -> + %% preprocess and compute total number of chars If = {_S, Len} = print_length(Term, D, RecDefFun, Enc, Str), + %% use Len as CHAR_MAX if M0 = -1 M = max_cs(M0, Len), if Len < Ll - Col, Len =< M -> + %% write the whole thing on a single line when there is room write(If); true -> + %% compute the indentation TInd for tagged tuples and records TInd = while_fail([-1, 4], fun(I) -> cind(If, Col, Ll, M, I, 0, 0) end, 1), pp(If, Col, Ll, M, TInd, indent(Col), 0, 0) end; print(Term, _Col, _Ll, _D, _M, _RF, _Enc, _Str) -> + %% atomic data types (bignums, atoms, ...) are never truncated io_lib:write(Term). %%% %%% Local functions %%% +%% use M only if nonnegative, otherwise use Len as default value max_cs(M, Len) when M < 0 -> Len; max_cs(M, _Len) -> M. -define(ATM(T), is_list(element(1, T))). +-define(ATM_PAIR(Pair), + ?ATM(element(2, element(1, Pair))) % Key + andalso + ?ATM(element(3, element(1, Pair)))). % Value -define(ATM_FLD(Field), ?ATM(element(4, element(1, Field)))). pp({_S, Len} = If, Col, Ll, M, _TInd, _Ind, LD, W) @@ -140,9 +157,8 @@ pp({{tuple,true,L}, _Len}, Col, Ll, M, TInd, Ind, LD, W) -> pp({{tuple,false,L}, _Len}, Col, Ll, M, TInd, Ind, LD, W) -> [${, pp_list(L, Col + 1, Ll, M, TInd, indent(1, Ind), LD, $,, W + 1), $}]; pp({{map,Pairs},_Len}, Col, Ll, M, TInd, Ind, LD, W) -> - [$#,${, pp_list(Pairs, Col + 2, Ll, M, TInd, indent(2, Ind), LD, $,, W + 1), $}]; -pp({{map_pair,K,V},_Len}, Col, Ll, M, TInd, Ind, LD, W) -> - [pp(K, Col, Ll, M, TInd, Ind, LD, W), " => ", pp(V, Col, Ll, M, TInd, Ind, LD, W)]; + [$#, ${, pp_map(Pairs, Col + 2, Ll, M, TInd, indent(2, Ind), LD, W + 1), + $}]; pp({{record,[{Name,NLen} | L]}, _Len}, Col, Ll, M, TInd, Ind, LD, W) -> [Name, ${, pp_record(L, NLen, Col, Ll, M, TInd, Ind, LD, W + NLen+1), $}]; pp({{bin,S}, _Len}, Col, Ll, M, _TInd, Ind, LD, W) -> @@ -153,6 +169,7 @@ pp({S, _Len}, _Col, _Ll, _M, _TInd, _Ind, _LD, _W) -> %% Print a tagged tuple by indenting the rest of the elements %% differently to the tag. Tuple has size >= 2. pp_tag_tuple([{Tag,Tlen} | L], Col, Ll, M, TInd, Ind, LD, W) -> + %% this uses TInd TagInd = Tlen + 2, Tcol = Col + TagInd, S = $,, @@ -166,6 +183,46 @@ pp_tag_tuple([{Tag,Tlen} | L], Col, Ll, M, TInd, Ind, LD, W) -> [Tag, S | pp_list(L, Tcol, Ll, M, TInd, Indent, LD, S, W+Tlen+1)] end. +pp_map([], _Col, _Ll, _M, _TInd, _Ind, _LD, _W) -> + ""; +pp_map({dots, _}, _Col, _Ll, _M, _TInd, _Ind, _LD, _W) -> + "..."; +pp_map([P | Ps], Col, Ll, M, TInd, Ind, LD, W) -> + {PS, PW} = pp_pair(P, Col, Ll, M, TInd, Ind, last_depth(Ps, LD), W), + [PS | pp_pairs_tail(Ps, Col, Col + PW, Ll, M, TInd, Ind, LD, PW)]. + +pp_pairs_tail([], _Col0, _Col, _Ll, _M, _TInd, _Ind, _LD, _W) -> + ""; +pp_pairs_tail({dots, _}, _Col0, _Col, _M, _Ll, _TInd, _Ind, _LD, _W) -> + ",..."; +pp_pairs_tail([{_, Len}=P | Ps], Col0, Col, Ll, M, TInd, Ind, LD, W) -> + LD1 = last_depth(Ps, LD), + ELen = 1 + Len, + if + LD1 =:= 0, ELen + 1 < Ll - Col, W + ELen + 1 =< M, ?ATM_PAIR(P); + LD1 > 0, ELen < Ll - Col - LD1, W + ELen + LD1 =< M, ?ATM_PAIR(P) -> + [$,, write_pair(P) | + pp_pairs_tail(Ps, Col0, Col+ELen, Ll, M, TInd, Ind, LD, W+ELen)]; + true -> + {PS, PW} = pp_pair(P, Col0, Ll, M, TInd, Ind, LD1, 0), + [$,, $\n, Ind, PS | + pp_pairs_tail(Ps, Col0, Col0 + PW, Ll, M, TInd, Ind, LD, PW)] + end. + +pp_pair({_, Len}=Pair, Col, Ll, M, _TInd, _Ind, LD, W) + when Len < Ll - Col - LD, Len + W + LD =< M -> + {write_pair(Pair), if + ?ATM_PAIR(Pair) -> + Len; + true -> + Ll % force nl + end}; +pp_pair({{map_pair, K, V}, _Len}, Col0, Ll, M, TInd, Ind0, LD, W) -> + I = map_value_indent(TInd), + Ind = indent(I, Ind0), + {[pp(K, Col0, Ll, M, TInd, Ind0, LD, W), " =>\n", + Ind | pp(V, Col0 + I, Ll, M, TInd, Ind, LD, 0)], Ll}. % force nl + pp_record([], _Nlen, _Col, _Ll, _M, _TInd, _Ind, _LD, _W) -> ""; pp_record({dots, _}, _Nlen, _Col, _Ll, _M, _TInd, _Ind, _LD, _W) -> @@ -204,9 +261,14 @@ pp_field({_, Len}=Fl, Col, Ll, M, _TInd, _Ind, LD, W) end}; pp_field({{field, Name, NameL, F}, _Len}, Col0, Ll, M, TInd, Ind0, LD, W0) -> {Col, Ind, S, W} = rec_indent(NameL, TInd, Col0, Ind0, W0 + NameL), - {[Name, " = ", S | pp(F, Col, Ll, M, TInd, Ind, LD, W)], Ll}. % force nl + Sep = case S of + [$\n | _] -> " ="; + _ -> " = " + end, + {[Name, Sep, S | pp(F, Col, Ll, M, TInd, Ind, LD, W)], Ll}. % force nl rec_indent(RInd, TInd, Col0, Ind0, W0) -> + %% this uses TInd Nl = (TInd > 0) and (RInd > TInd), DCol = case Nl of true -> TInd; @@ -285,14 +347,15 @@ pp_binary(S, N, _N0, Ind) -> S end. +%% write the whole thing on a single line write({{tuple, _IsTagged, L}, _}) -> [${, write_list(L, $,), $}]; write({{list, L}, _}) -> [$[, write_list(L, $|), $]]; write({{map, Pairs}, _}) -> [$#,${, write_list(Pairs, $,), $}]; -write({{map_pair, K, V}, _}) -> - [write(K)," => ",write(V)]; +write({{map_pair, _K, _V}, _}=Pair) -> + write_pair(Pair); write({{record, [{Name,_} | L]}, _}) -> [Name, ${, write_fields(L), $}]; write({{bin, S}, _}) -> @@ -300,6 +363,9 @@ write({{bin, S}, _}) -> write({S, _}) -> S. +write_pair({{map_pair, K, V}, _}) -> + [write(K), " => ", write(V)]. + write_fields([]) -> ""; write_fields({dots, _}) -> @@ -333,7 +399,7 @@ write_tail(E, S) -> %% The depth (D) is used for extracting and counting the characters to %% print. The structure is kept so that the returned intermediate -%% format can be formatted. The separators (list, tuple, record) are +%% format can be formatted. The separators (list, tuple, record, map) are %% counted but need to be added later. %% D =/= 0 @@ -343,9 +409,14 @@ print_length({}, _D, _RF, _Enc, _Str) -> {"{}", 2}; print_length(#{}=M, _D, _RF, _Enc, _Str) when map_size(M) =:= 0 -> {"#{}", 3}; +print_length(Atom, _D, _RF, Enc, _Str) when is_atom(Atom) -> + S = write_atom(Atom, Enc), + {S, lists:flatlength(S)}; print_length(List, D, RF, Enc, Str) when is_list(List) -> + %% only flat lists are "printable" case Str andalso printable_list(List, D, Enc) of true -> + %% print as string, escaping double-quotes in the list S = write_string(List, Enc), {S, length(S)}; %% Truncated lists could break some existing code. @@ -401,26 +472,28 @@ print_length(<<_/bitstring>>=Bin, D, _RF, Enc, Str) -> end; print_length(Term, _D, _RF, _Enc, _Str) -> S = io_lib:write(Term), - {S, lists:flatlength(S)}. + %% S can contain unicode, so iolist_size(S) cannot be used here + {S, string:length(S)}. print_length_map(_Map, 1, _RF, _Enc, _Str) -> {"#{...}", 6}; print_length_map(Map, D, RF, Enc, Str) when is_map(Map) -> - Pairs = print_length_map_pairs(maps:to_list(Map), D, RF, Enc, Str), + Pairs = print_length_map_pairs(erts_internal:maps_to_list(Map, D), D, RF, Enc, Str), {{map, Pairs}, list_length(Pairs, 3)}. print_length_map_pairs([], _D, _RF, _Enc, _Str) -> []; print_length_map_pairs(_Pairs, 1, _RF, _Enc, _Str) -> {dots, 3}; -print_length_map_pairs([{K,V}|Pairs], D, RF, Enc, Str) -> - [print_length_map_pair(K,V,D-1,RF,Enc,Str) | - print_length_map_pairs(Pairs,D-1,RF,Enc,Str)]. +print_length_map_pairs([{K, V} | Pairs], D, RF, Enc, Str) -> + [print_length_map_pair(K, V, D - 1, RF, Enc, Str) | + print_length_map_pairs(Pairs, D - 1, RF, Enc, Str)]. print_length_map_pair(K, V, D, RF, Enc, Str) -> {KS, KL} = print_length(K, D, RF, Enc, Str), {VS, VL} = print_length(V, D, RF, Enc, Str), - {{map_pair, {KS,KL}, {VS,VL}}, KL + VL}. + KL1 = KL + 4, + {{map_pair, {KS, KL1}, {VS, VL}}, KL1 + VL}. print_length_tuple(_Tuple, 1, _RF, _Enc, _Str) -> {"{...}", 5}; @@ -432,7 +505,7 @@ print_length_tuple(Tuple, D, RF, Enc, Str) -> print_length_record(_Tuple, 1, _RF, _RDefs, _Enc, _Str) -> {"{...}", 5}; print_length_record(Tuple, D, RF, RDefs, Enc, Str) -> - Name = [$# | io_lib:write_atom(element(1, Tuple))], + Name = [$# | write_atom(element(1, Tuple), Enc)], NameL = length(Name), Elements = tl(tuple_to_list(Tuple)), L = print_length_fields(RDefs, D - 1, Elements, RF, Enc, Str), @@ -447,7 +520,7 @@ print_length_fields([Def | Defs], D, [E | Es], RF, Enc, Str) -> print_length_fields(Defs, D - 1, Es, RF, Enc, Str)]. print_length_field(Def, D, E, RF, Enc, Str) -> - Name = io_lib:write_atom(Def), + Name = write_atom(Def, Enc), {S, L} = print_length(E, D, RF, Enc, Str), NameL = length(Name) + 3, {{field, Name, NameL, {S, L}}, NameL + L}. @@ -483,6 +556,7 @@ list_length_tail({_, Len}, Acc) -> %% ?CHARS printable characters has depth 1. -define(CHARS, 4). +%% only flat lists are "printable" printable_list(_L, 1, _Enc) -> false; printable_list(L, _D, latin1) -> @@ -595,6 +669,11 @@ printable_char(C,unicode) -> C > 16#DFFF andalso C < 16#FFFE orelse C > 16#FFFF andalso C =< 16#10FFFF. +write_atom(A, latin1) -> + io_lib:write_atom_as_latin1(A); +write_atom(A, _Uni) -> + io_lib:write_atom(A). + write_string(S, latin1) -> io_lib:write_latin1_string(S, $"); %" write_string(S, _Uni) -> @@ -612,6 +691,8 @@ cind({{tuple,true,L}, _Len}, Col, Ll, M, Ind, LD, W) -> cind_tag_tuple(L, Col, Ll, M, Ind, LD, W + 1); cind({{tuple,false,L}, _Len}, Col, Ll, M, Ind, LD, W) -> cind_list(L, Col + 1, Ll, M, Ind, LD, W + 1); +cind({{map,Pairs},_Len}, Col, Ll, M, Ind, LD, W) -> + cind_map(Pairs, Col + 2, Ll, M, Ind, LD, W + 2); cind({{record,[{_Name,NLen} | L]}, _Len}, Col, Ll, M, Ind, LD, W) -> cind_record(L, NLen, Col, Ll, M, Ind, LD, W + NLen + 1); cind({{bin,_S}, _Len}, _Col, _Ll, _M, Ind, _LD, _W) -> @@ -637,6 +718,48 @@ cind_tag_tuple([{_Tag,Tlen} | L], Col, Ll, M, Ind, LD, W) -> throw(no_good) end. +cind_map([P | Ps], Col, Ll, M, Ind, LD, W) -> + PW = cind_pair(P, Col, Ll, M, Ind, last_depth(Ps, LD), W), + cind_pairs_tail(Ps, Col, Col + PW, Ll, M, Ind, LD, W + PW); +cind_map(_, _Col, _Ll, _M, Ind, _LD, _W) -> + Ind. + +cind_pairs_tail([{_, Len}=P | Ps], Col0, Col, Ll, M, Ind, LD, W) -> + LD1 = last_depth(Ps, LD), + ELen = 1 + Len, + if + LD1 =:= 0, ELen + 1 < Ll - Col, W + ELen + 1 =< M, ?ATM_PAIR(P); + LD1 > 0, ELen < Ll - Col - LD1, W + ELen + LD1 =< M, ?ATM_PAIR(P) -> + cind_pairs_tail(Ps, Col0, Col + ELen, Ll, M, Ind, LD, W + ELen); + true -> + PW = cind_pair(P, Col0, Ll, M, Ind, LD1, 0), + cind_pairs_tail(Ps, Col0, Col0 + PW, Ll, M, Ind, LD, PW) + end; +cind_pairs_tail(_, _Col0, _Col, _Ll, _M, Ind, _LD, _W) -> + Ind. + +cind_pair({{map_pair, _Key, _Value}, Len}=Pair, Col, Ll, M, _Ind, LD, W) + when Len < Ll - Col - LD, Len + W + LD =< M -> + if + ?ATM_PAIR(Pair) -> + Len; + true -> + Ll + end; +cind_pair({{map_pair, K, V}, _Len}, Col0, Ll, M, Ind, LD, W0) -> + cind(K, Col0, Ll, M, Ind, LD, W0), + I = map_value_indent(Ind), + cind(V, Col0 + I, Ll, M, Ind, LD, 0), + Ll. + +map_value_indent(TInd) -> + case TInd > 0 of + true -> + TInd; + false -> + 4 + end. + cind_record([F | Fs], Nlen, Col0, Ll, M, Ind, LD, W0) -> Nind = Nlen + 1, {Col, W} = cind_rec(Nind, Col0, Ll, M, Ind, W0), @@ -736,9 +859,11 @@ while_fail([], _F, V) -> while_fail([A | As], F, V) -> try F(A) catch _ -> while_fail(As, F, V) end. +%% make a string of N spaces indent(N) when is_integer(N), N > 0 -> chars($\s, N-1). +%% prepend N spaces onto Ind indent(1, Ind) -> % Optimization of common case [$\s | Ind]; indent(4, Ind) -> % Optimization of common case diff --git a/lib/stdlib/src/lib.erl b/lib/stdlib/src/lib.erl index eb24516c50..be11e86100 100644 --- a/lib/stdlib/src/lib.erl +++ b/lib/stdlib/src/lib.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2013. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -22,9 +22,12 @@ -export([flush_receive/0, error_message/2, progname/0, nonl/1, send/2, sendw/2, eval_str/1]). +-export([extended_parse_exprs/1, extended_parse_term/1, + subst_values_for_vars/2]). + -export([format_exception/6, format_exception/7, format_stacktrace/4, format_stacktrace/5, - format_call/4, format_call/5, format_fun/1]). + format_call/4, format_call/5, format_fun/1, format_fun/2]). -spec flush_receive() -> 'ok'. @@ -73,7 +76,7 @@ nonl([H|T]) -> [H|nonl(T)]. send(To, Msg) -> To ! Msg. --spec sendw(To, Msg) -> Msg when +-spec sendw(To, Msg) -> term() when To :: pid() | atom() | {atom(), node()}, Msg :: term(). @@ -127,6 +130,224 @@ all_white([$\t|T]) -> all_white(T); all_white([]) -> true; all_white(_) -> false. +%% `Tokens' is assumed to have been scanned with the 'text' option. +%% The annotations of the returned expressions are locations. +%% +%% Can handle pids, ports, references, and external funs ("items"). +%% Known items are represented by variables in the erl_parse tree, and +%% the items themselves are stored in the returned bindings. + +-spec extended_parse_exprs(Tokens) -> + {'ok', ExprList, Bindings} | {'error', ErrorInfo} when + Tokens :: [erl_scan:token()], + ExprList :: [erl_parse:abstract_expr()], + Bindings :: erl_eval:binding_struct(), + ErrorInfo :: erl_parse:error_info(). + +extended_parse_exprs(Tokens) -> + Ts = tokens_fixup(Tokens), + case erl_parse:parse_exprs(Ts) of + {ok, Exprs0} -> + {Exprs, Bs} = expr_fixup(Exprs0), + {ok, reset_expr_anno(Exprs), Bs}; + _ErrorInfo -> + erl_parse:parse_exprs(reset_token_anno(Ts)) + end. + +tokens_fixup([]) -> []; +tokens_fixup([T|Ts]=Ts0) -> + try token_fixup(Ts0) of + {NewT, NewTs} -> + [NewT|tokens_fixup(NewTs)] + catch + _:_ -> + [T|tokens_fixup(Ts)] + end. + +token_fixup(Ts) -> + {AnnoL, NewTs, FixupTag} = unscannable(Ts), + String = lists:append([erl_anno:text(A) || A <- AnnoL]), + _ = (fixup_fun(FixupTag))(String), + NewAnno = erl_anno:set_text(fixup_text(FixupTag), hd(AnnoL)), + {{string, NewAnno, String}, NewTs}. + +unscannable([{'#', A1}, {var, A2, 'Fun'}, {'<', A3}, {atom, A4, _}, + {'.', A5}, {float, A6, _}, {'>', A7}|Ts]) -> + {[A1, A2, A3, A4, A5, A6, A7], Ts, function}; +unscannable([{'#', A1}, {var, A2, 'Fun'}, {'<', A3}, {atom, A4, _}, + {'.', A5}, {atom, A6, _}, {'.', A7}, {integer, A8, _}, + {'>', A9}|Ts]) -> + {[A1, A2, A3, A4, A5, A6, A7, A8, A9], Ts, function}; +unscannable([{'<', A1}, {float, A2, _}, {'.', A3}, {integer, A4, _}, + {'>', A5}|Ts]) -> + {[A1, A2, A3, A4, A5], Ts, pid}; +unscannable([{'#', A1}, {var, A2, 'Port'}, {'<', A3}, {float, A4, _}, + {'>', A5}|Ts]) -> + {[A1, A2, A3, A4, A5], Ts, port}; +unscannable([{'#', A1}, {var, A2, 'Ref'}, {'<', A3}, {float, A4, _}, + {'.', A5}, {float, A6, _}, {'>', A7}|Ts]) -> + {[A1, A2, A3, A4, A5, A6, A7], Ts, reference}. + +expr_fixup(Expr0) -> + {Expr, Bs, _} = expr_fixup(Expr0, erl_eval:new_bindings(), 1), + {Expr, Bs}. + +expr_fixup({string,A,S}=T, Bs0, I) -> + try string_fixup(A, S) of + Value -> + Var = new_var(I), + Bs = erl_eval:add_binding(Var, Value, Bs0), + {{var, A, Var}, Bs, I+1} + catch + _:_ -> + {T, Bs0, I} + end; +expr_fixup(Tuple, Bs0, I0) when is_tuple(Tuple) -> + {L, Bs, I} = expr_fixup(tuple_to_list(Tuple), Bs0, I0), + {list_to_tuple(L), Bs, I}; +expr_fixup([E0|Es0], Bs0, I0) -> + {E, Bs1, I1} = expr_fixup(E0, Bs0, I0), + {Es, Bs, I} = expr_fixup(Es0, Bs1, I1), + {[E|Es], Bs, I}; +expr_fixup(T, Bs, I) -> + {T, Bs, I}. + +string_fixup(A, S) -> + Text = erl_anno:text(A), + FixupTag = fixup_tag(Text, S), + (fixup_fun(FixupTag))(S). + +new_var(I) -> + list_to_atom(lists:concat(['__ExtendedParseExprs_', I, '__'])). + +reset_token_anno(Tokens) -> + [setelement(2, T, (reset_anno())(element(2, T))) || T <- Tokens]. + +reset_expr_anno(Exprs) -> + [erl_parse:map_anno(reset_anno(), E) || E <- Exprs]. + +reset_anno() -> + fun(A) -> erl_anno:new(erl_anno:location(A)) end. + +fixup_fun(function) -> fun function/1; +fixup_fun(pid) -> fun erlang:list_to_pid/1; +fixup_fun(port) -> fun erlang:list_to_port/1; +fixup_fun(reference) -> fun erlang:list_to_ref/1. + +function(S) -> + %% External function. + {ok, [_, _, _, + {atom, _, Module}, _, + {atom, _, Function}, _, + {integer, _, Arity}|_], _} = erl_scan:string(S), + erlang:make_fun(Module, Function, Arity). + +fixup_text(function) -> "function"; +fixup_text(pid) -> "pid"; +fixup_text(port) -> "port"; +fixup_text(reference) -> "reference". + +fixup_tag("function", "#"++_) -> function; +fixup_tag("pid", "<"++_) -> pid; +fixup_tag("port", "#"++_) -> port; +fixup_tag("reference", "#"++_) -> reference. + +%%% End of extended_parse_exprs. + +%% `Tokens' is assumed to have been scanned with the 'text' option. +%% +%% Can handle pids, ports, references, and external funs. + +-spec extended_parse_term(Tokens) -> + {'ok', Term} | {'error', ErrorInfo} when + Tokens :: [erl_scan:token()], + Term :: term(), + ErrorInfo :: erl_parse:error_info(). + +extended_parse_term(Tokens) -> + case extended_parse_exprs(Tokens) of + {ok, [Expr], Bindings} -> + try normalise(Expr, Bindings) of + Term -> + {ok, Term} + catch + _:_ -> + Loc = erl_anno:location(element(2, Expr)), + {error,{Loc,?MODULE,"bad term"}} + end; + {ok, [_,Expr|_], _Bindings} -> + Loc = erl_anno:location(element(2, Expr)), + {error,{Loc,?MODULE,"bad term"}}; + {error, _} = Error -> + Error + end. + +%% From erl_parse. +normalise({var, _, V}, Bs) -> + {value, Value} = erl_eval:binding(V, Bs), + Value; +normalise({char,_,C}, _Bs) -> C; +normalise({integer,_,I}, _Bs) -> I; +normalise({float,_,F}, _Bs) -> F; +normalise({atom,_,A}, _Bs) -> A; +normalise({string,_,S}, _Bs) -> S; +normalise({nil,_}, _Bs) -> []; +normalise({bin,_,Fs}, Bs) -> + {value, B, _} = + eval_bits:expr_grp(Fs, [], + fun(E, _) -> + {value, normalise(E, Bs), []} + end, [], true), + B; +normalise({cons,_,Head,Tail}, Bs) -> + [normalise(Head, Bs)|normalise(Tail, Bs)]; +normalise({tuple,_,Args}, Bs) -> + list_to_tuple(normalise_list(Args, Bs)); +normalise({map,_,Pairs}, Bs) -> + maps:from_list(lists:map(fun + %% only allow '=>' + ({map_field_assoc,_,K,V}) -> + {normalise(K, Bs),normalise(V, Bs)} + end, Pairs)); +%% Special case for unary +/-. +normalise({op,_,'+',{char,_,I}}, _Bs) -> I; +normalise({op,_,'+',{integer,_,I}}, _Bs) -> I; +normalise({op,_,'+',{float,_,F}}, _Bs) -> F; +normalise({op,_,'-',{char,_,I}}, _Bs) -> -I; %Weird, but compatible! +normalise({op,_,'-',{integer,_,I}}, _Bs) -> -I; +normalise({op,_,'-',{float,_,F}}, _Bs) -> -F; +normalise({'fun',_,{function,{atom,_,M},{atom,_,F},{integer,_,A}}}, _Bs) -> + %% Since "#Fun<M.F.A>" is recognized, "fun M:F/A" should be too. + fun M:F/A. + +normalise_list([H|T], Bs) -> + [normalise(H, Bs)|normalise_list(T, Bs)]; +normalise_list([], _Bs) -> + []. + +%% To be used on ExprList and Bindings returned from extended_parse_exprs(). +%% Substitute {value, A, Item} for {var, A, ExtendedParseVar}. +%% {value, A, Item} is a shell/erl_eval convention, and for example +%% the linter cannot handle it. + +-spec subst_values_for_vars(ExprList, Bindings) -> [term()] when + ExprList :: [erl_parse:abstract_expr()], + Bindings :: erl_eval:binding_struct(). + +subst_values_for_vars({var, A, V}=Var, Bs) -> + case erl_eval:binding(V, Bs) of + {value, Value} -> + {value, A, Value}; + unbound -> + Var + end; +subst_values_for_vars(L, Bs) when is_list(L) -> + [subst_values_for_vars(E, Bs) || E <- L]; +subst_values_for_vars(T, Bs) when is_tuple(T) -> + list_to_tuple(subst_values_for_vars(tuple_to_list(T), Bs)); +subst_values_for_vars(T, _Bs) -> + T. + %%% Formatting of exceptions, mfa:s and funs. %% -> iolist() (no \n at end) @@ -179,7 +400,11 @@ format_call(I, ForMForFun, As, FormatFun, Enc) format_call("", n_spaces(I-1), ForMForFun, As, FormatFun, Enc). %% -> iolist() (no \n at end) -format_fun(Fun) when is_function(Fun) -> +format_fun(Fun) -> + format_fun(Fun, latin1). + +%% -> iolist() (no \n at end) +format_fun(Fun, Enc) when is_function(Fun) -> {module, M} = erlang:fun_info(Fun, module), {name, F} = erlang:fun_info(Fun, name), {arity, A} = erlang:fun_info(Fun, arity), @@ -189,9 +414,9 @@ format_fun(Fun) when is_function(Fun) -> {type, local} when M =:= erl_eval -> io_lib:fwrite(<<"interpreted function with arity ~w">>, [A]); {type, local} -> - mfa_to_string(M, F, A); + mfa_to_string(M, F, A, Enc); {type, external} -> - mfa_to_string(M, F, A) + mfa_to_string(M, F, A, Enc) end. analyze_exception(error, Term, Stack) -> @@ -233,11 +458,11 @@ explain_reason({badarg,V}, error=Cl, [], PF, S, _Enc) -> % orelse, andalso format_value(V, <<"bad argument: ">>, Cl, PF, S); explain_reason(badarith, error, [], _PF, _S, _Enc) -> <<"an error occurred when evaluating an arithmetic expression">>; -explain_reason({badarity,{Fun,As}}, error, [], _PF, _S, _Enc) +explain_reason({badarity,{Fun,As}}, error, [], _PF, _S, Enc) when is_function(Fun) -> %% Only the arity is displayed, not the arguments As. - io_lib:fwrite(<<"~s called with ~s">>, - [format_fun(Fun), argss(length(As))]); + io_lib:fwrite(<<"~ts called with ~s">>, + [format_fun(Fun, Enc), argss(length(As))]); explain_reason({badfun,Term}, error=Cl, [], PF, S, _Enc) -> format_value(Term, <<"bad function ">>, Cl, PF, S); explain_reason({badmatch,Term}, error=Cl, [], PF, S, _Enc) -> @@ -268,14 +493,15 @@ explain_reason({try_clause,V}, error=Cl, [], PF, S, _Enc) -> %% "there is no try clause with a true guard sequence and a %% pattern matching..." format_value(V, <<"no try clause matching ">>, Cl, PF, S); -explain_reason(undef, error, [{M,F,A,_}], _PF, _S, _Enc) -> +explain_reason(undef, error, [{M,F,A,_}], _PF, _S, Enc) -> %% Only the arity is displayed, not the arguments, if there are any. - io_lib:fwrite(<<"undefined function ~s">>, - [mfa_to_string(M, F, n_args(A))]); -explain_reason({shell_undef,F,A,_}, error, [], _PF, _S, _Enc) -> + io_lib:fwrite(<<"undefined function ~ts">>, + [mfa_to_string(M, F, n_args(A), Enc)]); +explain_reason({shell_undef,F,A,_}, error, [], _PF, _S, Enc) -> %% Give nicer reports for undefined shell functions %% (but not when the user actively calls shell_default:F(...)). - io_lib:fwrite(<<"undefined shell command ~s/~w">>, [F, n_args(A)]); + FS = to_string(F, Enc), + io_lib:fwrite(<<"undefined shell command ~ts/~w">>, [FS, n_args(A)]); %% Exit codes returned by erl_eval only: explain_reason({argument_limit,_Fun}, error, [], _PF, _S, _Enc) -> io_lib:fwrite(<<"limit of number of arguments to interpreted function" @@ -325,17 +551,18 @@ format_stacktrace1(S0, Stack0, PF, SF, Enc) -> format_stacktrace2(S, Stack, 1, PF, Enc). format_stacktrace2(S, [{M,F,A,L}|Fs], N, PF, Enc) when is_integer(A) -> - [io_lib:fwrite(<<"~s~s ~s ~s">>, + [io_lib:fwrite(<<"~s~s ~ts ~ts">>, [sep(N, S), origin(N, M, F, A), - mfa_to_string(M, F, A), + mfa_to_string(M, F, A, Enc), location(L)]) | format_stacktrace2(S, Fs, N + 1, PF, Enc)]; format_stacktrace2(S, [{M,F,As,_}|Fs], N, PF, Enc) when is_list(As) -> A = length(As), CalledAs = [S,<<" called as ">>], C = format_call("", CalledAs, {M,F}, As, PF, Enc), - [io_lib:fwrite(<<"~s~s ~s\n~s~ts">>, - [sep(N, S), origin(N, M, F, A), mfa_to_string(M, F, A), + [io_lib:fwrite(<<"~s~s ~ts\n~s~ts">>, + [sep(N, S), origin(N, M, F, A), + mfa_to_string(M, F, A, Enc), CalledAs, C]) | format_stacktrace2(S, Fs, N + 1, PF, Enc)]; format_stacktrace2(_S, [], _N, _PF, _Enc) -> @@ -346,7 +573,7 @@ location(L) -> Line = proplists:get_value(line, L), if File =/= undefined, Line =/= undefined -> - io_lib:format("(~s, line ~w)", [File, Line]); + io_lib:format("(~ts, line ~w)", [File, Line]); true -> "" end. @@ -373,10 +600,10 @@ format_call(ErrStr, Pre1, ForMForFun, As, PF, Enc) -> {yes,Op} -> format_op(ErrStr, Pre1, Op, As, PF, Enc); no -> - MFs = mf_to_string(ForMForFun, Arity), - I1 = iolist_size([Pre1,ErrStr|MFs]), + MFs = mf_to_string(ForMForFun, Arity, Enc), + I1 = string:length([Pre1,ErrStr|MFs]), S1 = pp_arguments(PF, As, I1, Enc), - S2 = pp_arguments(PF, As, iolist_size([Pre1|MFs]), Enc), + S2 = pp_arguments(PF, As, string:length([Pre1|MFs]), Enc), Long = count_nl(pp_arguments(PF, [a2345,b2345], I1, Enc)) > 0, case Long or (count_nl(S2) < count_nl(S1)) of true -> @@ -435,10 +662,10 @@ printable_list(latin1, As) -> printable_list(_, As) -> io_lib:printable_list(As). -mfa_to_string(M, F, A) -> - io_lib:fwrite(<<"~s/~w">>, [mf_to_string({M, F}, A), A]). +mfa_to_string(M, F, A, Enc) -> + io_lib:fwrite(<<"~ts/~w">>, [mf_to_string({M, F}, A, Enc), A]). -mf_to_string({M, F}, A) -> +mf_to_string({M, F}, A, Enc) -> case erl_internal:bif(M, F, A) of true -> io_lib:fwrite(<<"~w">>, [F]); @@ -449,13 +676,15 @@ mf_to_string({M, F}, A) -> {yes, F} -> atom_to_list(F); no -> - io_lib:fwrite(<<"~w:~w">>, [M, F]) + FS = to_string(F, Enc), + io_lib:fwrite(<<"~w:~ts">>, [M, FS]) end end; -mf_to_string(Fun, _A) when is_function(Fun) -> - format_fun(Fun); -mf_to_string(F, _A) -> - io_lib:fwrite(<<"~w">>, [F]). +mf_to_string(Fun, _A, Enc) when is_function(Fun) -> + format_fun(Fun, Enc); +mf_to_string(F, _A, Enc) -> + FS = to_string(F, Enc), + io_lib:fwrite(<<"~ts">>, [FS]). format_value(V, ErrStr, Class, PF, S) -> Pre1Sz = exited_size(Class), @@ -504,9 +733,14 @@ exited(exit) -> exited(throw) -> <<"exception throw: ">>. +to_string(A, latin1) -> + io_lib:write_atom_as_latin1(A); +to_string(A, _) -> + io_lib:write_atom(A). + size(latin1, S) -> {iolist_size(S),S}; size(_, S0) -> S = unicode:characters_to_list(S0, unicode), true = is_list(S), - {length(S),S}. + {string:length(S),S}. diff --git a/lib/stdlib/src/lists.erl b/lib/stdlib/src/lists.erl index 62b6ca8a21..af9d63ddd6 100644 --- a/lib/stdlib/src/lists.erl +++ b/lib/stdlib/src/lists.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2013. All Rights Reserved. +%% Copyright Ericsson AB 1996-2016. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -39,7 +39,8 @@ -export([all/2,any/2,map/2,flatmap/2,foldl/3,foldr/3,filter/2, partition/2,zf/2,filtermap/2, mapfoldl/3,mapfoldr/3,foreach/2,takewhile/2,dropwhile/2,splitwith/2, - split/2]). + split/2, + join/2]). %%% BIFs -export([keyfind/3, keymember/3, keysearch/3, member/2, reverse/2]). @@ -1439,6 +1440,18 @@ split(N, [H|T], R) -> split(_, [], _) -> badarg. +-spec join(Sep, List1) -> List2 when + Sep :: T, + List1 :: [T], + List2 :: [T], + T :: term(). + +join(_Sep, []) -> []; +join(Sep, [H|T]) -> [H|join_prepend(Sep, T)]. + +join_prepend(_Sep, []) -> []; +join_prepend(Sep, [H|T]) -> [Sep,H|join_prepend(Sep,T)]. + %%% ================================================================= %%% Here follows the implementation of the sort functions. %%% @@ -2267,6 +2280,8 @@ ukeysplit_2(I, Y, EY, [Z | L], R) -> ukeysplit_2(_I, Y, _EY, [], R) -> [Y | R]. +-dialyzer({no_improper_lists, ukeymergel/3}). + ukeymergel(I, [T1, [H2 | T2], [H3 | T3] | L], Acc) -> %% The fourth argument, [H2 | H3] (=HdM), may confuse type %% checkers. Its purpose is to ensure that the tests H2 == HdM diff --git a/lib/stdlib/src/log_mf_h.erl b/lib/stdlib/src/log_mf_h.erl index 35723bbc9e..393da9ab27 100644 --- a/lib/stdlib/src/log_mf_h.erl +++ b/lib/stdlib/src/log_mf_h.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2013. All Rights Reserved. +%% Copyright Ericsson AB 1996-2016. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. diff --git a/lib/stdlib/src/maps.erl b/lib/stdlib/src/maps.erl index 3c798b7a04..5dafdb282a 100644 --- a/lib/stdlib/src/maps.erl +++ b/lib/stdlib/src/maps.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2013. All Rights Reserved. +%% Copyright Ericsson AB 2013-2016. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -20,17 +20,18 @@ -module(maps). --export([get/3,filter/2,fold/3, map/2, - size/1, +-export([get/3, filter/2,fold/3, + map/2, size/1, + update_with/3, update_with/4, without/2, with/2]). - -%%% BIFs +%% BIFs -export([get/2, find/2, from_list/1, is_key/2, keys/1, merge/2, - new/0, put/3, remove/2, + new/0, put/3, remove/2, take/2, to_list/1, update/3, values/1]). +%% Shadowed by erl_bif_types: maps:get/2 -spec get(Key,Map) -> Value when Key :: term(), Map :: map(), @@ -46,7 +47,7 @@ get(_,_) -> erlang:nif_error(undef). find(_,_) -> erlang:nif_error(undef). - +%% Shadowed by erl_bif_types: maps:from_list/1 -spec from_list(List) -> Map when List :: [{Key,Value}], Key :: term(), @@ -56,6 +57,7 @@ find(_,_) -> erlang:nif_error(undef). from_list(_) -> erlang:nif_error(undef). +%% Shadowed by erl_bif_types: maps:is_key/2 -spec is_key(Key,Map) -> boolean() when Key :: term(), Map :: map(). @@ -71,6 +73,7 @@ is_key(_,_) -> erlang:nif_error(undef). keys(_) -> erlang:nif_error(undef). +%% Shadowed by erl_bif_types: maps:merge/2 -spec merge(Map1,Map2) -> Map3 when Map1 :: map(), Map2 :: map(), @@ -86,6 +89,7 @@ merge(_,_) -> erlang:nif_error(undef). new() -> erlang:nif_error(undef). +%% Shadowed by erl_bif_types: maps:put/3 -spec put(Key,Value,Map1) -> Map2 when Key :: term(), Value :: term(), @@ -102,7 +106,15 @@ put(_,_,_) -> erlang:nif_error(undef). remove(_,_) -> erlang:nif_error(undef). +-spec take(Key,Map1) -> {Value,Map2} | error when + Key :: term(), + Map1 :: map(), + Value :: term(), + Map2 :: map(). + +take(_,_) -> erlang:nif_error(undef). +%% Shadowed by erl_bif_types: maps:to_list/1 -spec to_list(Map) -> [{Key,Value}] when Map :: map(), Key :: term(), @@ -111,6 +123,7 @@ remove(_,_) -> erlang:nif_error(undef). to_list(_) -> erlang:nif_error(undef). +%% Shadowed by erl_bif_types: maps:update/3 -spec update(Key,Value,Map1) -> Map2 when Key :: term(), Value :: term(), @@ -127,8 +140,40 @@ update(_,_,_) -> erlang:nif_error(undef). values(_) -> erlang:nif_error(undef). +%% End of BIFs + +-spec update_with(Key,Fun,Map1) -> Map2 when + Key :: term(), + Map1 :: map(), + Map2 :: map(), + Fun :: fun((Value1 :: term()) -> Value2 :: term()). + +update_with(Key,Fun,Map) when is_function(Fun,1), is_map(Map) -> + try maps:get(Key,Map) of + Val -> maps:update(Key,Fun(Val),Map) + catch + error:{badkey,_} -> + erlang:error({badkey,Key},[Key,Fun,Map]) + end; +update_with(Key,Fun,Map) -> + erlang:error(error_type(Map),[Key,Fun,Map]). + + +-spec update_with(Key,Fun,Init,Map1) -> Map2 when + Key :: term(), + Map1 :: Map1, + Map2 :: Map2, + Fun :: fun((Value1 :: term()) -> Value2 :: term()), + Init :: term(). + +update_with(Key,Fun,Init,Map) when is_function(Fun,1), is_map(Map) -> + case maps:find(Key,Map) of + {ok,Val} -> maps:update(Key,Fun(Val),Map); + error -> maps:put(Key,Init,Map) + end; +update_with(Key,Fun,Init,Map) -> + erlang:error(error_type(Map),[Key,Fun,Init,Map]). -%%% End of BIFs -spec get(Key, Map, Default) -> Value | Default when Key :: term(), @@ -205,7 +250,7 @@ size(Val) -> K :: term(). without(Ks,M) when is_list(Ks), is_map(M) -> - maps:from_list([{K,V}||{K,V} <- maps:to_list(M), not lists:member(K, Ks)]); + lists:foldl(fun(K, M1) -> ?MODULE:remove(K, M1) end, M, Ks); without(Ks,M) -> erlang:error(error_type(M),[Ks,M]). @@ -216,8 +261,16 @@ without(Ks,M) -> Map2 :: map(), K :: term(). -with(Ks,M) when is_list(Ks), is_map(M) -> - maps:from_list([{K,V}||{K,V} <- maps:to_list(M), lists:member(K, Ks)]); +with(Ks,Map1) when is_list(Ks), is_map(Map1) -> + Fun = fun(K, List) -> + case ?MODULE:find(K, Map1) of + {ok, V} -> + [{K, V} | List]; + error -> + List + end + end, + ?MODULE:from_list(lists:foldl(Fun, [], Ks)); with(Ks,M) -> erlang:error(error_type(M),[Ks,M]). diff --git a/lib/stdlib/src/math.erl b/lib/stdlib/src/math.erl index 06dfc01bbb..3a3b384d8f 100644 --- a/lib/stdlib/src/math.erl +++ b/lib/stdlib/src/math.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2012. All Rights Reserved. +%% Copyright Ericsson AB 1996-2016. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -25,7 +25,9 @@ -export([sin/1, cos/1, tan/1, asin/1, acos/1, atan/1, atan2/2, sinh/1, cosh/1, tanh/1, asinh/1, acosh/1, atanh/1, exp/1, log/1, - log2/1, log10/1, pow/2, sqrt/1, erf/1, erfc/1]). + log2/1, log10/1, pow/2, sqrt/1, erf/1, erfc/1, + ceil/1, floor/1, + fmod/2]). -spec acos(X) -> float() when X :: number(). @@ -63,6 +65,11 @@ atan2(_, _) -> atanh(_) -> erlang:nif_error(undef). +-spec ceil(X) -> float() when + X :: number(). +ceil(_) -> + erlang:nif_error(undef). + -spec cos(X) -> float() when X :: number(). cos(_) -> @@ -88,6 +95,16 @@ erfc(_) -> exp(_) -> erlang:nif_error(undef). +-spec floor(X) -> float() when + X :: number(). +floor(_) -> + erlang:nif_error(undef). + +-spec fmod(X, Y) -> float() when + X :: number(), Y :: number(). +fmod(_, _) -> + erlang:nif_error(undef). + -spec log(X) -> float() when X :: number(). log(_) -> diff --git a/lib/stdlib/src/ms_transform.erl b/lib/stdlib/src/ms_transform.erl index b67b6f75d7..6616e957c0 100644 --- a/lib/stdlib/src/ms_transform.erl +++ b/lib/stdlib/src/ms_transform.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2002-2015. All Rights Reserved. +%% Copyright Ericsson AB 2002-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -91,12 +91,12 @@ format_error(?ERR_GUARDMATCH) -> "fun with guard matching ('=' in guard) is illegal as match_spec as well"; format_error({?ERR_GUARDLOCALCALL, Name, Arithy}) -> lists:flatten(io_lib:format("fun containing the local function call " - "'~w/~w' (called in guard) " + "'~tw/~w' (called in guard) " "cannot be translated into match_spec", [Name, Arithy])); format_error({?ERR_GUARDREMOTECALL, Module, Name, Arithy}) -> lists:flatten(io_lib:format("fun containing the remote function call " - "'~w:~w/~w' (called in guard) " + "'~w:~tw/~w' (called in guard) " "cannot be translated into match_spec", [Module,Name,Arithy])); format_error({?ERR_GUARDELEMENT, Str}) -> @@ -117,12 +117,12 @@ format_error(?ERR_BODYMATCH) -> "fun with body matching ('=' in body) is illegal as match_spec"; format_error({?ERR_BODYLOCALCALL, Name, Arithy}) -> lists:flatten(io_lib:format("fun containing the local function " - "call '~w/~w' (called in body) " + "call '~tw/~w' (called in body) " "cannot be translated into match_spec", [Name,Arithy])); format_error({?ERR_BODYREMOTECALL, Module, Name, Arithy}) -> lists:flatten(io_lib:format("fun containing the remote function call " - "'~w:~w/~w' (called in body) " + "'~w:~tw/~w' (called in body) " "cannot be translated into match_spec", [Module,Name,Arithy])); format_error({?ERR_BODYELEMENT, Str}) -> @@ -147,15 +147,15 @@ format_error({?ERR_UNBOUND_VARIABLE, Str}) -> "into match_spec", [Str])); format_error({?ERR_HEADBADREC,Name}) -> lists:flatten( - io_lib:format("fun head contains unknown record type ~w",[Name])); + io_lib:format("fun head contains unknown record type ~tw",[Name])); format_error({?ERR_HEADBADFIELD,RName,FName}) -> lists:flatten( - io_lib:format("fun head contains reference to unknown field ~w in " - "record type ~w",[FName, RName])); + io_lib:format("fun head contains reference to unknown field ~tw in " + "record type ~tw",[FName, RName])); format_error({?ERR_HEADMULTIFIELD,RName,FName}) -> lists:flatten( - io_lib:format("fun head contains already defined field ~w in " - "record type ~w",[FName, RName])); + io_lib:format("fun head contains already defined field ~tw in " + "record type ~tw",[FName, RName])); format_error({?ERR_HEADDOLLARATOM,Atom}) -> lists:flatten( io_lib:format("fun head contains atom ~w, which conflics with reserved " @@ -166,28 +166,28 @@ format_error({?ERR_HEADBINMATCH,Atom}) -> "which cannot be translated into match_spec", [Atom])); format_error({?ERR_GUARDBADREC,Name}) -> lists:flatten( - io_lib:format("fun guard contains unknown record type ~w",[Name])); + io_lib:format("fun guard contains unknown record type ~tw",[Name])); format_error({?ERR_GUARDBADFIELD,RName,FName}) -> lists:flatten( - io_lib:format("fun guard contains reference to unknown field ~w in " - "record type ~w",[FName, RName])); + io_lib:format("fun guard contains reference to unknown field ~tw in " + "record type ~tw",[FName, RName])); format_error({?ERR_GUARDMULTIFIELD,RName,FName}) -> lists:flatten( - io_lib:format("fun guard contains already defined field ~w in " - "record type ~w",[FName, RName])); + io_lib:format("fun guard contains already defined field ~tw in " + "record type ~tw",[FName, RName])); format_error({?ERR_BODYBADREC,Name}) -> lists:flatten( - io_lib:format("fun body contains unknown record type ~w",[Name])); + io_lib:format("fun body contains unknown record type ~tw",[Name])); format_error({?ERR_BODYBADFIELD,RName,FName}) -> lists:flatten( - io_lib:format("fun body contains reference to unknown field ~w in " - "record type ~w",[FName, RName])); + io_lib:format("fun body contains reference to unknown field ~tw in " + "record type ~tw",[FName, RName])); format_error({?ERR_BODYMULTIFIELD,RName,FName}) -> lists:flatten( - io_lib:format("fun body contains already defined field ~w in " - "record type ~w",[FName, RName])); + io_lib:format("fun body contains already defined field ~tw in " + "record type ~tw",[FName, RName])); format_error(Else) -> - lists:flatten(io_lib:format("Unknown error code ~w",[Else])). + lists:flatten(io_lib:format("Unknown error code ~tw",[Else])). %% %% Called when translating in shell @@ -224,8 +224,9 @@ transform_from_shell(Dialect, Clauses, BoundEnvironment) -> %% Called when translating during compiling %% --spec parse_transform(Forms, Options) -> Forms when - Forms :: [erl_parse:abstract_form()], +-spec parse_transform(Forms, Options) -> Forms2 when + Forms :: [erl_parse:abstract_form() | erl_parse:form_info()], + Forms2 :: [erl_parse:abstract_form() | erl_parse:form_info()], Options :: term(). parse_transform(Forms, _Options) -> @@ -307,15 +308,18 @@ cleanup_filename({Old,OldRec,OldWarnings}) -> add_record_definition({Name,FieldList}) -> {KeyList,_} = lists:foldl( - fun({record_field,_,{atom,Line0,FieldName}},{L,C}) -> - {[{FieldName,C,{atom,Line0,undefined}}|L],C+1}; - ({record_field,_,{atom,_,FieldName},Def},{L,C}) -> - {[{FieldName,C,Def}|L],C+1} - end, + fun(F, {L,C}) -> {[record_field(F, C)|L],C+1} end, {[],2}, FieldList), put_records([{Name,KeyList}|get_records()]). +record_field({record_field,_,{atom,Line0,FieldName}}, C) -> + {FieldName,C,{atom,Line0,undefined}}; +record_field({record_field,_,{atom,_,FieldName},Def}, C) -> + {FieldName,C,Def}; +record_field({typed_record_field,Field,_Type}, C) -> + record_field(Field, C). + forms([F0|Fs0]) -> F1 = form(F0), Fs1 = forms(Fs0), @@ -447,6 +451,8 @@ check_type(_,[{record,_,_,_}],ets) -> ok; check_type(_,[{cons,_,_,_}],dbg) -> ok; +check_type(_,[{nil,_}],dbg) -> + ok; check_type(Line0,[{match,_,{var,_,_},X}],Any) -> check_type(Line0,[X],Any); check_type(Line0,[{match,_,X,{var,_,_}}],Any) -> @@ -495,10 +501,20 @@ tg0(Line,[H|T],B) -> tg({match,Line,_,_},B) -> throw({error,Line,?ERR_GENMATCH+B#tgd.eb}); -tg({op, Line, Operator, O1, O2}, B) -> - {tuple, Line, [{atom, Line, Operator}, tg(O1,B), tg(O2,B)]}; -tg({op, Line, Operator, O1}, B) -> - {tuple, Line, [{atom, Line, Operator}, tg(O1,B)]}; +tg({op, Line, Operator, O1, O2}=Expr, B) -> + case erl_eval:partial_eval(Expr) of + Expr -> + {tuple, Line, [{atom, Line, Operator}, tg(O1, B), tg(O2, B)]}; + Value -> + Value + end; +tg({op, Line, Operator, O1}=Expr, B) -> + case erl_eval:partial_eval(Expr) of + Expr -> + {tuple, Line, [{atom, Line, Operator}, tg(O1, B)]}; + Value -> + Value + end; tg({call, _Line, {atom, Line2, bindings},[]},_B) -> {atom, Line2, '$*'}; tg({call, _Line, {atom, Line2, object},[]},_B) -> @@ -717,7 +733,7 @@ tg(T,B) when is_tuple(T), tuple_size(T) >= 2 -> throw({error,Line,{?ERR_GENELEMENT+B#tgd.eb, translate_language_element(Element)}}); tg(Other,B) -> - Element = io_lib:format("unknown element ~w", [Other]), + Element = io_lib:format("unknown element ~tw", [Other]), throw({error,unknown,{?ERR_GENELEMENT+B#tgd.eb,Element}}). transform_head([V],OuterBound) -> diff --git a/lib/stdlib/src/orddict.erl b/lib/stdlib/src/orddict.erl index 37cf0084f0..9a2772949b 100644 --- a/lib/stdlib/src/orddict.erl +++ b/lib/stdlib/src/orddict.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2015. All Rights Reserved. +%% Copyright Ericsson AB 1996-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -22,7 +22,7 @@ %% Standard interface. -export([new/0,is_key/2,to_list/1,from_list/1,size/1,is_empty/1]). --export([fetch/2,find/2,fetch_keys/1,erase/2]). +-export([fetch/2,find/2,fetch_keys/1,erase/2,take/2]). -export([store/3,append/3,append_list/3,update/3,update/4,update_counter/3]). -export([fold/3,map/2,filter/2,merge/3]). @@ -106,6 +106,23 @@ erase(Key, [{K,_}=E|Dict]) when Key > K -> erase(_Key, [{_K,_Val}|Dict]) -> Dict; %Key == K erase(_, []) -> []. +-spec take(Key, Orddict) -> {Value, Orddict1} | error when + Orddict :: orddict(Key, Value), + Orddict1 :: orddict(Key, Value), + Key :: term(), + Value :: term(). + +take(Key, Dict) -> + take_1(Key, Dict, []). + +take_1(Key, [{K,_}|_], _Acc) when Key < K -> + error; +take_1(Key, [{K,_}=P|D], Acc) when Key > K -> + take_1(Key, D, [P|Acc]); +take_1(_Key, [{_K,Value}|D], Acc) -> + {Value,lists:reverse(Acc, D)}; +take_1(_, [], _) -> error. + -spec store(Key, Value, Orddict1) -> Orddict2 when Orddict1 :: orddict(Key, Value), Orddict2 :: orddict(Key, Value). diff --git a/lib/stdlib/src/ordsets.erl b/lib/stdlib/src/ordsets.erl index 6010b41006..569407f5ef 100644 --- a/lib/stdlib/src/ordsets.erl +++ b/lib/stdlib/src/ordsets.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2011. All Rights Reserved. +%% Copyright Ericsson AB 1996-2016. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. diff --git a/lib/stdlib/src/otp_internal.erl b/lib/stdlib/src/otp_internal.erl index 2d77888512..5b488cc677 100644 --- a/lib/stdlib/src/otp_internal.erl +++ b/lib/stdlib/src/otp_internal.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1999-2015. All Rights Reserved. +%% Copyright Ericsson AB 1999-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -23,6 +23,8 @@ %%---------------------------------------------------------------------- +-dialyzer({no_match, obsolete/3}). + -type tag() :: 'deprecated' | 'removed'. %% | 'experimental'. -type mfas() :: mfa() | {atom(), atom(), [byte()]}. -type release() :: string(). @@ -33,7 +35,7 @@ obsolete(Module, Name, Arity) -> case obsolete_1(Module, Name, Arity) of {deprecated=Tag,{_,_,_}=Replacement} -> - {Tag,Replacement,"in a future release"}; + {Tag,Replacement,"a future release"}; {_,String}=Ret when is_list(String) -> Ret; {_,_,_}=Ret -> @@ -45,21 +47,6 @@ obsolete(Module, Name, Arity) -> obsolete_1(net, _, _) -> {deprecated, "module 'net' obsolete; use 'net_adm'"}; -obsolete_1(erl_internal, builtins, 0) -> - {deprecated, {erl_internal, bif, 2}}; - -obsolete_1(erl_eval, seq, 2) -> - {deprecated, {erl_eval, exprs, 2}}; -obsolete_1(erl_eval, seq, 3) -> - {deprecated, {erl_eval, exprs, 3}}; -obsolete_1(erl_eval, arg_list, 2) -> - {deprecated, {erl_eval, expr_list, 2}}; -obsolete_1(erl_eval, arg_list, 3) -> - {deprecated, {erl_eval, expr_list, 3}}; - -obsolete_1(erlang, hash, 2) -> - {deprecated, {erlang, phash2, 2}}; - obsolete_1(erlang, now, 0) -> {deprecated, "Deprecated BIF. See the \"Time and Time Correction in Erlang\" " @@ -68,185 +55,240 @@ obsolete_1(erlang, now, 0) -> obsolete_1(calendar, local_time_to_universal_time, 1) -> {deprecated, {calendar, local_time_to_universal_time_dst, 1}}; -obsolete_1(rpc, safe_multi_server_call, A) when A =:= 2; A =:= 3 -> - {deprecated, {rpc, multi_server_call, A}}; +%% *** STDLIB added in OTP 20 *** + +obsolete_1(gen_fsm, start, 3) -> + {deprecated, {gen_statem, start, 3}}; +obsolete_1(gen_fsm, start, 4) -> + {deprecated, {gen_statem, start, 4}}; + +obsolete_1(gen_fsm, start_link, 3) -> + {deprecated, {gen_statem, start_link, 3}}; +obsolete_1(gen_fsm, start_link, 4) -> + {deprecated, {gen_statem, start_link, 4}}; + +obsolete_1(gen_fsm, stop, 1) -> + {deprecated, {gen_statem, stop, 1}}; +obsolete_1(gen_fsm, stop, 3) -> + {deprecated, {gen_statem, stop, 3}}; + +obsolete_1(gen_fsm, enter_loop, 4) -> + {deprecated, {gen_statem, enter_loop, 4}}; +obsolete_1(gen_fsm, enter_loop, 5) -> + {deprecated, {gen_statem, enter_loop, 5}}; +obsolete_1(gen_fsm, enter_loop, 6) -> + {deprecated, {gen_statem, enter_loop, 6}}; + +obsolete_1(gen_fsm, reply, 2) -> + {deprecated, {gen_statem, reply, 2}}; + +obsolete_1(gen_fsm, send_event, 2) -> + {deprecated, {gen_statem, cast, 2}}; +obsolete_1(gen_fsm, send_all_state_event, 2) -> + {deprecated, {gen_statem, cast, 2}}; + +obsolete_1(gen_fsm, sync_send_event, 2) -> + {deprecated, {gen_statem, call, 2}}; +obsolete_1(gen_fsm, sync_send_event, 3) -> + {deprecated, {gen_statem, call, 3}}; +obsolete_1(gen_fsm, sync_send_all_state_event, 2) -> + {deprecated, {gen_statem, call, 2}}; +obsolete_1(gen_fsm, sync_send_all_state_event, 3) -> + {deprecated, {gen_statem, call, 3}}; -%% *** CRYPTO add in R16B01 *** +obsolete_1(gen_fsm, start_timer, 2) -> + {deprecated, {erlang, start_timer, 3}}; +obsolete_1(gen_fsm, cancel_timer, 1) -> + {deprecated, {erlang, cancel_timer, 1}}; +obsolete_1(gen_fsm, send_event_after, 2) -> + {deprecated, {erlang, send_after, 3}}; + +%% *** CRYPTO added in OTP 20 *** + +obsolete_1(crypto, rand_uniform, 2) -> + {deprecated, {rand, uniform, 1}}; + +%% *** CRYPTO added in OTP 19 *** + +obsolete_1(crypto, rand_bytes, 1) -> + {removed, {crypto, strong_rand_bytes, 1}, "20.0"}; + +%% *** CRYPTO added in R16B01 *** obsolete_1(crypto, md4, 1) -> - {deprecated, {crypto, hash, 2}}; + {removed, {crypto, hash, 2}, "20.0"}; obsolete_1(crypto, md5, 1) -> - {deprecated, {crypto, hash, 2}}; + {removed, {crypto, hash, 2}, "20.0"}; obsolete_1(crypto, sha, 1) -> - {deprecated, {crypto, hash, 2}}; + {removed, {crypto, hash, 2}, "20.0"}; obsolete_1(crypto, md4_init, 0) -> - {deprecated, {crypto, hash_init, 1}}; + {removed, {crypto, hash_init, 1}, "20.0"}; obsolete_1(crypto, md5_init, 0) -> - {deprecated, {crypto, hash_init, 1}}; + {removed, {crypto, hash_init, 1}, "20.0"}; obsolete_1(crypto, sha_init, 0) -> - {deprecated, {crypto, hash_init, 1}}; + {removed, {crypto, hash_init, 1}, "20.0"}; obsolete_1(crypto, md4_update, 2) -> - {deprecated, {crypto, hash_update, 2}}; + {removed, {crypto, hash_update, 2}, "20.0"}; obsolete_1(crypto, md5_update, 2) -> - {deprecated, {crypto, hash_update, 2}}; + {removed, {crypto, hash_update, 2}, "20.0"}; obsolete_1(crypto, sha_update, 2) -> - {deprecated, {crypto, hash_update, 2}}; + {removed, {crypto, hash_update, 2}, "20.0"}; obsolete_1(crypto, md4_final, 1) -> - {deprecated, {crypto, hash_final, 1}}; + {removed, {crypto, hash_final, 1}, "20.0"}; obsolete_1(crypto, md5_final, 1) -> - {deprecated, {crypto, hash_final, 1}}; + {removed, {crypto, hash_final, 1}, "20.0"}; obsolete_1(crypto, sha_final, 1) -> - {deprecated, {crypto, hash_final, 1}}; + {removed, {crypto, hash_final, 1}, "20.0"}; obsolete_1(crypto, md5_mac, 2) -> - {deprecated, {crypto, hmac, 3}}; + {removed, {crypto, hmac, 3}, "20.0"}; obsolete_1(crypto, sha_mac, 2) -> - {deprecated, {crypto, hmac, 3}}; + {removed, {crypto, hmac, 3}, "20.0"}; obsolete_1(crypto, sha_mac, 3) -> - {deprecated, {crypto, hmac, 4}}; + {removed, {crypto, hmac, 4}, "20.0"}; obsolete_1(crypto, sha_mac_96, 2) -> - {deprecated, {crypto, hmac, 4}}; + {removed, {crypto, hmac, 4}, "20.0"}; obsolete_1(crypto, md5_mac_96, 2) -> - {deprecated, {crypto, hmac, 4}}; + {removed, {crypto, hmac, 4}, "20.0"}; obsolete_1(crypto, rsa_sign, 2) -> - {deprecated, {crypto, sign, 4}}; + {removed, {crypto, sign, 4}, "20.0"}; obsolete_1(crypto, rsa_sign, 3) -> - {deprecated, {crypto, sign, 4}}; + {removed, {crypto, sign, 4}, "20.0"}; obsolete_1(crypto, rsa_verify, 3) -> - {deprecated, {crypto, verify, 5}}; + {removed, {crypto, verify, 5}, "20.0"}; obsolete_1(crypto, rsa_verify, 4) -> - {deprecated, {crypto, verify, 5}}; + {removed, {crypto, verify, 5}, "20.0"}; obsolete_1(crypto, dss_sign, 2) -> - {deprecated, {crypto, sign, 4}}; + {removed, {crypto, sign, 4}, "20.0"}; obsolete_1(crypto, dss_sign, 3) -> - {deprecated, {crypto, sign, 4}}; + {removed, {crypto, sign, 4}, "20.0"}; obsolete_1(crypto, dss_verify, 3) -> - {deprecated, {crypto, verify, 5}}; + {removed, {crypto, verify, 5}, "20.0"}; obsolete_1(crypto, dss_verify, 4) -> - {deprecated, {crypto, verify, 5}}; + {removed, {crypto, verify, 5}, "20.0"}; obsolete_1(crypto, mod_exp, 3) -> - {deprecated, {crypto, mod_pow, 3}}; + {removed, {crypto, mod_pow, 3}, "20.0"}; obsolete_1(crypto, dh_compute_key, 3) -> - {deprecated, {crypto, compute_key, 4}}; + {removed, {crypto, compute_key, 4}, "20.0"}; obsolete_1(crypto, dh_generate_key, 1) -> - {deprecated, {crypto, generate_key, 2}}; + {removed, {crypto, generate_key, 2}, "20.0"}; obsolete_1(crypto, dh_generate_key, 2) -> - {deprecated, {crypto, generate_key, 3}}; + {removed, {crypto, generate_key, 3}, "20.0"}; obsolete_1(crypto, des_cbc_encrypt, 3) -> - {deprecated, {crypto, block_encrypt, 4}}; + {removed, {crypto, block_encrypt, 4}, "20.0"}; obsolete_1(crypto, des3_cbc_encrypt, 5) -> - {deprecated, {crypto, block_encrypt, 4}}; + {removed, {crypto, block_encrypt, 4}, "20.0"}; obsolete_1(crypto, des_ecb_encrypt, 2) -> - {deprecated, {crypto, block_encrypt, 3}}; + {removed, {crypto, block_encrypt, 3}, "20.0"}; obsolete_1(crypto, des_ede3_cbc_encrypt, 5) -> - {deprecated, {crypto, block_encrypt, 4}}; + {removed, {crypto, block_encrypt, 4}, "20.0"}; obsolete_1(crypto, des_cfb_encrypt, 3) -> - {deprecated, {crypto, block_encrypt, 4}}; + {removed, {crypto, block_encrypt, 4}, "20.0"}; obsolete_1(crypto, des3_cfb_encrypt, 5) -> - {deprecated, {crypto, block_encrypt, 4}}; + {removed, {crypto, block_encrypt, 4}, "20.0"}; obsolete_1(crypto, blowfish_ecb_encrypt, 2) -> - {deprecated, {crypto, block_encrypt, 3}}; + {removed, {crypto, block_encrypt, 3}, "20.0"}; obsolete_1(crypto, blowfish_cbc_encrypt, 3) -> - {deprecated, {crypto, block_encrypt, 4}}; + {removed, {crypto, block_encrypt, 4}, "20.0"}; obsolete_1(crypto, blowfish_cfb64_encrypt, 3) -> - {deprecated, {crypto, block_encrypt, 4}}; + {removed, {crypto, block_encrypt, 4}, "20.0"}; obsolete_1(crypto, blowfish_ofb64_encrypt, 3) -> - {deprecated, {crypto, block_encrypt, 4}}; + {removed, {crypto, block_encrypt, 4}, "20.0"}; obsolete_1(crypto, aes_cfb_128_encrypt, 3) -> - {deprecated, {crypto, block_encrypt, 4}}; + {removed, {crypto, block_encrypt, 4}, "20.0"}; obsolete_1(crypto, aes_cbc_128_encrypt, 3) -> - {deprecated, {crypto, block_encrypt, 4}}; + {removed, {crypto, block_encrypt, 4}, "20.0"}; obsolete_1(crypto, aes_cbc_256_encrypt, 3) -> - {deprecated, {crypto, block_encrypt, 4}}; + {removed, {crypto, block_encrypt, 4}, "20.0"}; obsolete_1(crypto,rc2_cbc_encrypt, 3) -> - {deprecated, {crypto, block_encrypt, 4}}; + {removed, {crypto, block_encrypt, 4}, "20.0"}; obsolete_1(crypto,rc2_40_cbc_encrypt, 3) -> - {deprecated, {crypto, block_encrypt, 4}}; + {removed, {crypto, block_encrypt, 4}, "20.0"}; obsolete_1(crypto, des_cbc_decrypt, 3) -> - {deprecated, {crypto, block_decrypt, 4}}; + {removed, {crypto, block_decrypt, 4}, "20.0"}; obsolete_1(crypto, des3_cbc_decrypt, 5) -> - {deprecated, {crypto, block_decrypt, 4}}; + {removed, {crypto, block_decrypt, 4}, "20.0"}; obsolete_1(crypto, des_ecb_decrypt, 2) -> - {deprecated, {crypto, block_decrypt, 3}}; + {removed, {crypto, block_decrypt, 3}, "20.0"}; obsolete_1(crypto, des_ede3_cbc_decrypt, 5) -> - {deprecated, {crypto, block_decrypt, 4}}; + {removed, {crypto, block_decrypt, 4}, "20.0"}; obsolete_1(crypto, des_cfb_decrypt, 3) -> - {deprecated, {crypto, block_decrypt, 4}}; + {removed, {crypto, block_decrypt, 4}, "20.0"}; obsolete_1(crypto, des3_cfb_decrypt, 5) -> - {deprecated, {crypto, block_decrypt, 4}}; + {removed, {crypto, block_decrypt, 4}, "20.0"}; obsolete_1(crypto, blowfish_ecb_decrypt, 2) -> - {deprecated, {crypto, block_decrypt, 3}}; + {removed, {crypto, block_decrypt, 3}, "20.0"}; obsolete_1(crypto, blowfish_cbc_decrypt, 3) -> - {deprecated, {crypto, block_decrypt, 4}}; + {removed, {crypto, block_decrypt, 4}, "20.0"}; obsolete_1(crypto, blowfish_cfb64_decrypt, 3) -> - {deprecated, {crypto, block_decrypt, 4}}; + {removed, {crypto, block_decrypt, 4}, "20.0"}; obsolete_1(crypto, blowfish_ofb64_decrypt, 3) -> - {deprecated, {crypto, block_decrypt, 4}}; + {removed, {crypto, block_decrypt, 4}, "20.0"}; obsolete_1(crypto, aes_cfb_128_decrypt, 3) -> - {deprecated, {crypto, block_decrypt, 4}}; + {removed, {crypto, block_decrypt, 4}, "20.0"}; obsolete_1(crypto, aes_cbc_128_decrypt, 3) -> - {deprecated, {crypto, block_decrypt, 4}}; + {removed, {crypto, block_decrypt, 4}, "20.0"}; obsolete_1(crypto, aes_cbc_256_decrypt, 3) -> - {deprecated, {crypto, block_decrypt, 4}}; + {removed, {crypto, block_decrypt, 4}, "20.0"}; obsolete_1(crypto,rc2_cbc_decrypt, 3) -> - {deprecated, {crypto, block_decrypt, 4}}; + {removed, {crypto, block_decrypt, 4}, "20.0"}; obsolete_1(crypto,rc2_40_cbc_decrypt, 3) -> - {deprecated, {crypto, block_decrypt, 4}}; + {removed, {crypto, block_decrypt, 4}, "20.0"}; obsolete_1(crypto, aes_ctr_stream_decrypt, 2) -> - {deprecated, {crypto, stream_decrypt, 2}}; + {removed, {crypto, stream_decrypt, 2}, "20.0"}; obsolete_1(crypto, aes_ctr_stream_encrypt, 2) -> - {deprecated, {crypto, stream_encrypt, 2}}; + {removed, {crypto, stream_encrypt, 2}, "20.0"}; obsolete_1(crypto, aes_ctr_decrypt, 3) -> - {deprecated, {crypto, stream_decrypt, 2}}; + {removed, {crypto, stream_decrypt, 2}, "20.0"}; obsolete_1(crypto, aes_ctr_encrypt, 3) -> - {deprecated, {crypto, stream_encrypt, 2}}; + {removed, {crypto, stream_encrypt, 2}, "20.0"}; obsolete_1(crypto, rc4_encrypt, 2) -> - {deprecated, {crypto, stream_encrypt, 2}}; + {removed, {crypto, stream_encrypt, 2}, "20.0"}; obsolete_1(crypto, rc4_encrypt_with_state, 2) -> - {deprecated, {crypto, stream_encrypt, 2}}; + {removed, {crypto, stream_encrypt, 2}, "20.0"}; obsolete_1(crypto, aes_ctr_stream_init, 2) -> - {deprecated, {crypto, stream_init, 3}}; + {removed, {crypto, stream_init, 3}, "20.0"}; obsolete_1(crypto, rc4_set_key, 1) -> - {deprecated, {crypto, stream_init, 2}}; + {removed, {crypto, stream_init, 2}, "20.0"}; obsolete_1(crypto, rsa_private_decrypt, 3) -> - {deprecated, {crypto, private_decrypt, 4}}; + {removed, {crypto, private_decrypt, 4}, "20.0"}; obsolete_1(crypto, rsa_public_decrypt, 3) -> - {deprecated, {crypto, public_decrypt, 4}}; + {removed, {crypto, public_decrypt, 4}, "20.0"}; obsolete_1(crypto, rsa_private_encrypt, 3) -> - {deprecated, {crypto, private_encrypt, 4}}; + {removed, {crypto, private_encrypt, 4}, "20.0"}; obsolete_1(crypto, rsa_public_encrypt, 3) -> - {deprecated, {crypto, public_encrypt, 4}}; + {removed, {crypto, public_encrypt, 4}, "20.0"}; obsolete_1(crypto, des_cfb_ivec, 2) -> - {deprecated, {crypto, next_iv, 3}}; + {removed, {crypto, next_iv, 3}, "20.0"}; obsolete_1(crypto,des_cbc_ivec, 1) -> - {deprecated, {crypto, next_iv, 2}}; + {removed, {crypto, next_iv, 2}, "20.0"}; obsolete_1(crypto, aes_cbc_ivec, 1) -> - {deprecated, {crypto, next_iv, 2}}; + {removed, {crypto, next_iv, 2}, "20.0"}; obsolete_1(crypto,info, 0) -> - {deprecated, {crypto, module_info, 0}}; + {removed, {crypto, module_info, 0}, "20.0"}; obsolete_1(crypto, strong_rand_mpint, 3) -> - {deprecated, "needed only by deprecated functions"}; + {removed, "removed in 20.0; only needed by removed functions"}; obsolete_1(crypto, erlint, 1) -> - {deprecated, "needed only by deprecated functions"}; + {removed, "removed in 20.0; only needed by removed functions"}; obsolete_1(crypto, mpint, 1) -> - {deprecated, "needed only by deprecated functions"}; + {removed, "removed in 20.0; only needed by removed functions"}; %% *** SNMP *** @@ -389,119 +431,23 @@ obsolete_1(http, cookie_header, 2) -> {removed,{httpc,cookie_header,2},"R15B" obsolete_1(http, stream_next, 1) -> {removed,{httpc,stream_next,1},"R15B"}; obsolete_1(http, default_profile, 0) -> {removed,{httpc,default_profile,0},"R15B"}; -obsolete_1(httpd, start, 0) -> {removed,{inets,start,[2,3]},"R14B"}; -obsolete_1(httpd, start, 1) -> {removed,{inets,start,[2,3]},"R14B"}; -obsolete_1(httpd, start_link, 0) -> {removed,{inets,start,[2,3]},"R14B"}; -obsolete_1(httpd, start_link, 1) -> {removed,{inets,start,[2,3]},"R14B"}; -obsolete_1(httpd, start_child, 0) -> {removed,{inets,start,[2,3]},"R14B"}; -obsolete_1(httpd, start_child, 1) -> {removed,{inets,start,[2,3]},"R14B"}; -obsolete_1(httpd, stop, 0) -> {removed,{inets,stop,2},"R14B"}; -obsolete_1(httpd, stop, 1) -> {removed,{inets,stop,2},"R14B"}; -obsolete_1(httpd, stop, 2) -> {removed,{inets,stop,2},"R14B"}; -obsolete_1(httpd, stop_child, 0) -> {removed,{inets,stop,2},"R14B"}; -obsolete_1(httpd, stop_child, 1) -> {removed,{inets,stop,2},"R14B"}; -obsolete_1(httpd, stop_child, 2) -> {removed,{inets,stop,2},"R14B"}; -obsolete_1(httpd, restart, 0) -> {removed,{httpd,reload_config,2},"R14B"}; -obsolete_1(httpd, restart, 1) -> {removed,{httpd,reload_config,2},"R14B"}; -obsolete_1(httpd, restart, 2) -> {removed,{httpd,reload_config,2},"R14B"}; -obsolete_1(httpd, block, 0) -> {removed,{httpd,reload_config,2},"R14B"}; -obsolete_1(httpd, block, 1) -> {removed,{httpd,reload_config,2},"R14B"}; -obsolete_1(httpd, block, 2) -> {removed,{httpd,reload_config,2},"R14B"}; -obsolete_1(httpd, block, 3) -> {removed,{httpd,reload_config,2},"R14B"}; -obsolete_1(httpd, block, 4) -> {removed,{httpd,reload_config,2},"R14B"}; -obsolete_1(httpd, unblock, 0) -> {removed,{httpd,reload_config,2},"R14B"}; -obsolete_1(httpd, unblock, 1) -> {removed,{httpd,reload_config,2},"R14B"}; -obsolete_1(httpd, unblock, 2) -> {removed,{httpd,reload_config,2},"R14B"}; -obsolete_1(httpd_util, key1search, 2) -> {removed,{proplists,get_value,2},"R13B"}; -obsolete_1(httpd_util, key1search, 3) -> {removed,{proplists,get_value,3},"R13B"}; -obsolete_1(ftp, open, 3) -> {removed,{inets,start,[2,3]},"R14B"}; -obsolete_1(ftp, force_active, 1) -> {removed,{inets,start,[2,3]},"R14B"}; - -%% Added in R12B-4. -obsolete_1(ssh_cm, connect, A) when 1 =< A, A =< 3 -> - {removed,{ssh,connect,A},"R14B"}; -obsolete_1(ssh_cm, listen, A) when 2 =< A, A =< 4 -> - {removed,{ssh,daemon,A},"R14B"}; -obsolete_1(ssh_cm, stop_listener, 1) -> - {removed,{ssh,stop_listener,[1,2]},"R14B"}; -obsolete_1(ssh_cm, session_open, A) when A =:= 2; A =:= 4 -> - {removed,{ssh_connection,session_channel,A},"R14B"}; -obsolete_1(ssh_cm, direct_tcpip, A) when A =:= 6; A =:= 8 -> - {removed,{ssh_connection,direct_tcpip,A},"R14B"}; -obsolete_1(ssh_cm, tcpip_forward, 3) -> - {removed,{ssh_connection,tcpip_forward,3},"R14B"}; -obsolete_1(ssh_cm, cancel_tcpip_forward, 3) -> - {removed,{ssh_connection,cancel_tcpip_forward,3},"R14B"}; -obsolete_1(ssh_cm, open_pty, A) when A =:= 3; A =:= 7; A =:= 9 -> - {removed,{ssh_connection,open_pty,A},"R14B"}; -obsolete_1(ssh_cm, setenv, 5) -> - {removed,{ssh_connection,setenv,5},"R14B"}; -obsolete_1(ssh_cm, shell, 2) -> - {removed,{ssh_connection,shell,2},"R14B"}; -obsolete_1(ssh_cm, exec, 4) -> - {removed,{ssh_connection,exec,4},"R14B"}; -obsolete_1(ssh_cm, subsystem, 4) -> - {removed,{ssh_connection,subsystem,4},"R14B"}; -obsolete_1(ssh_cm, winch, A) when A =:= 4; A =:= 6 -> - {removed,{ssh_connection,window_change,A},"R14B"}; -obsolete_1(ssh_cm, signal, 3) -> - {removed,{ssh_connection,signal,3},"R14B"}; -obsolete_1(ssh_cm, attach, A) when A =:= 2; A =:= 3 -> - {removed,"no longer useful; removed in R14B"}; -obsolete_1(ssh_cm, detach, 2) -> - {removed,"no longer useful; removed in R14B"}; -obsolete_1(ssh_cm, set_user_ack, 4) -> - {removed,"no longer useful; removed in R14B"}; -obsolete_1(ssh_cm, adjust_window, 3) -> - {removed,{ssh_connection,adjust_window,3},"R14B"}; -obsolete_1(ssh_cm, close, 2) -> - {removed,{ssh_connection,close,2},"R14B"}; -obsolete_1(ssh_cm, stop, 1) -> - {removed,{ssh,close,1},"R14B"}; -obsolete_1(ssh_cm, send_eof, 2) -> - {removed,{ssh_connection,send_eof,2},"R14B"}; -obsolete_1(ssh_cm, send, A) when A =:= 3; A =:= 4 -> - {removed,{ssh_connection,send,A},"R14B"}; -obsolete_1(ssh_cm, send_ack, A) when 3 =< A, A =< 5 -> - {removed,{ssh_connection,send,[3,4]},"R14B"}; -obsolete_1(ssh_ssh, connect, A) when 1 =< A, A =< 3 -> - {removed,{ssh,shell,A},"R14B"}; -obsolete_1(ssh_sshd, listen, A) when 0 =< A, A =< 3 -> - {removed,{ssh,daemon,[1,2,3]},"R14B"}; -obsolete_1(ssh_sshd, stop, 1) -> - {removed,{ssh,stop_listener,1},"R14B"}; - %% Added in R13A. obsolete_1(regexp, _, _) -> {removed, "removed in R15; use the re module instead"}; -obsolete_1(lists, flat_length, 1) -> - {removed,{lists,flatlength,1},"R14"}; - -obsolete_1(ssh_sftp, connect, A) when 1 =< A, A =< 3 -> - {removed,{ssh_sftp,start_channel,A},"R14B"}; -obsolete_1(ssh_sftp, stop, 1) -> - {removed,{ssh_sftp,stop_channel,1},"R14B"}; - -%% Added in R13B01. -obsolete_1(ssl_pkix, decode_cert_file, A) when A =:= 1; A =:= 2 -> - {removed,"removed in R14A; use public_key:pem_to_der/1 and public_key:pkix_decode_cert/2 instead"}; -obsolete_1(ssl_pkix, decode_cert, A) when A =:= 1; A =:= 2 -> - {removed,{public_key,pkix_decode_cert,2},"R14A"}; - %% Added in R13B04. obsolete_1(erlang, concat_binary, 1) -> {removed,{erlang,list_to_binary,1},"R15B"}; %% Added in R14A. obsolete_1(ssl, peercert, 2) -> - {deprecated,"deprecated (will be removed in R15A); use ssl:peercert/1 and public_key:pkix_decode_cert/2 instead"}; + {removed ,"removed in R15A; use ssl:peercert/1 and public_key:pkix_decode_cert/2 instead"}; %% Added in R14B. obsolete_1(public_key, pem_to_der, 1) -> - {deprecated,"deprecated (will be removed in R15A); use file:read_file/1 and public_key:pem_decode/1"}; + {removed,"removed in R15A; use file:read_file/1 and public_key:pem_decode/1"}; obsolete_1(public_key, decode_private_key, A) when A =:= 1; A =:= 2 -> - {deprecated,{public_key,pem_entry_decode,1},"R15A"}; + {removed, "removed in R15A; use public_key:pem_entry_decode/1"}; %% Added in R14B03. obsolete_1(docb_gen, _, _) -> @@ -513,20 +459,18 @@ obsolete_1(docb_xml_check, _, _) -> %% Added in R15B obsolete_1(asn1rt, F, _) when F == load_driver; F == unload_driver -> - {deprecated,"deprecated (will be removed in OTP 18); has no effect as drivers are no longer used"}; + {removed,"removed (will be removed in OTP 18); has no effect as drivers are no longer used"}; obsolete_1(ssl, pid, 1) -> {removed,"was removed in R16; is no longer needed"}; obsolete_1(inviso, _, _) -> {removed,"the inviso application was removed in R16"}; %% Added in R15B01. -obsolete_1(gs, _, _) -> - {deprecated,"the gs application has been deprecated and will be removed in OTP 18; use the wx application instead"}; obsolete_1(ssh, sign_data, 2) -> - {deprecated,"deprecated (will be removed in R16A); use public_key:pem_decode/1, public_key:pem_entry_decode/1 " + {removed,"removed in R16A; use public_key:pem_decode/1, public_key:pem_entry_decode/1 " "and public_key:sign/3 instead"}; obsolete_1(ssh, verify_data, 3) -> - {deprecated,"deprecated (will be removed in R16A); use public_key:ssh_decode/1, and public_key:verify/4 instead"}; + {removed,"removed in R16A; use public_key:ssh_decode/1, and public_key:verify/4 instead"}; %% Added in R16 obsolete_1(wxCalendarCtrl, enableYearChange, _) -> %% wx bug documented? @@ -539,10 +483,6 @@ obsolete_1(wxPaintDC, new, 0) -> {deprecated,"deprecated function not available in wxWidgets-2.9 and later"}; obsolete_1(wxWindowDC, new, 0) -> {deprecated,"deprecated function not available in wxWidgets-2.9 and later"}; -obsolete_1(wxGraphicsContext, createLinearGradientBrush, 7) -> - {deprecated,"deprecated function not available in wxWidgets-2.9 and later"}; -obsolete_1(wxGraphicsContext, createRadialGradientBrush, 8) -> - {deprecated,"deprecated function not available in wxWidgets-2.9 and later"}; obsolete_1(wxGraphicsRenderer, createLinearGradientBrush, 7) -> {deprecated,"deprecated function not available in wxWidgets-2.9 and later"}; obsolete_1(wxGraphicsRenderer, createRadialGradientBrush, 8) -> @@ -568,72 +508,64 @@ obsolete_1(wxCursor, new, 4) -> %% Added in OTP 17. obsolete_1(asn1ct, decode,3) -> - {deprecated,"deprecated; use Mod:decode/2 instead"}; + {removed,"removed; use Mod:decode/2 instead"}; +obsolete_1(asn1ct, encode, 2) -> + {removed,"removed; use Mod:encode/2 instead"}; obsolete_1(asn1ct, encode, 3) -> - {deprecated,"deprecated; use Mod:encode/2 instead"}; + {removed,"removed; use Mod:encode/2 instead"}; obsolete_1(asn1rt, decode,3) -> - {deprecated,"deprecated; use Mod:decode/2 instead"}; + {removed,"removed; use Mod:decode/2 instead"}; obsolete_1(asn1rt, encode, 2) -> - {deprecated,"deprecated; use Mod:encode/2 instead"}; + {removed,"removed; use Mod:encode/2 instead"}; obsolete_1(asn1rt, encode, 3) -> - {deprecated,"deprecated; use Mod:encode/2 instead"}; + {removed,"removed; use Mod:encode/2 instead"}; obsolete_1(asn1rt, info, 1) -> - {deprecated,"deprecated; use Mod:info/0 instead"}; + {removed,"removed; use Mod:info/0 instead"}; obsolete_1(asn1rt, utf8_binary_to_list, 1) -> - {deprecated,{unicode,characters_to_list,1}}; + {removed,{unicode,characters_to_list,1},"OTP 20"}; obsolete_1(asn1rt, utf8_list_to_binary, 1) -> - {deprecated,{unicode,characters_to_binary,1}}; + {removed,{unicode,characters_to_binary,1},"OTP 20"}; %% Added in OTP 18. obsolete_1(core_lib, get_anno, 1) -> - {deprecated,{cerl,get_ann,1}}; + {removed,{cerl,get_ann,1},"19"}; obsolete_1(core_lib, set_anno, 2) -> - {deprecated,{cerl,set_ann,2}}; + {removed,{cerl,set_ann,2},"19"}; obsolete_1(core_lib, is_literal, 1) -> - {deprecated,{cerl,is_literal,1}}; + {removed,{cerl,is_literal,1},"19"}; obsolete_1(core_lib, is_literal_list, 1) -> - {deprecated,"deprecated; use lists:all(fun cerl:is_literal/1, L)" + {removed,"removed; use lists:all(fun cerl:is_literal/1, L)" " instead"}; obsolete_1(core_lib, literal_value, 1) -> - {deprecated,{core_lib,concrete,1}}; + {removed,{core_lib,concrete,1},"19"}; obsolete_1(erl_scan, set_attribute, 3) -> - {deprecated, - "deprecated (will be removed in OTP 19); use erl_anno:set_line/2 instead"}; + {removed,{erl_anno,set_line,2},"19.0"}; obsolete_1(erl_scan, attributes_info, 1) -> - {deprecated, - "deprecated (will be removed in OTP 19); use " + {removed,"removed in 19.0; use " "erl_anno:{column,line,location,text}/1 instead"}; obsolete_1(erl_scan, attributes_info, 2) -> - {deprecated, - "deprecated (will be removed in OTP 19); use " + {removed,"removed in 19.0; use " "erl_anno:{column,line,location,text}/1 instead"}; obsolete_1(erl_scan, token_info, 1) -> - {deprecated, - "deprecated (will be removed in OTP 19); use " + {removed,"removed in 19.0; use " "erl_scan:{category,column,line,location,symbol,text}/1 instead"}; obsolete_1(erl_scan, token_info, 2) -> - {deprecated, - "deprecated (will be removed in OTP 19); use " + {removed,"removed in 19.0; use " "erl_scan:{category,column,line,location,symbol,text}/1 instead"}; obsolete_1(erl_parse, set_line, 2) -> - {deprecated, - "deprecated (will be removed in OTP 19); use erl_anno:set_line/2 instead"}; + {removed,{erl_anno,set_line,2},"19.0"}; obsolete_1(erl_parse, get_attributes, 1) -> - {deprecated, - "deprecated (will be removed in OTP 19); use " + {removed,"removed in 19.0; use " "erl_anno:{column,line,location,text}/1 instead"}; obsolete_1(erl_parse, get_attribute, 2) -> - {deprecated, - "deprecated (will be removed in OTP 19); use " + {removed,"removed in 19.0; use " "erl_anno:{column,line,location,text}/1 instead"}; obsolete_1(erl_lint, modify_line, 2) -> - {deprecated, - "deprecated (will be removed in OTP 19); use erl_parse:map_anno/2 instead"}; + {removed,{erl_parse,map_anno,2},"19.0"}; obsolete_1(ssl, negotiated_next_protocol, 1) -> - {deprecated,{ssl,negotiated_protocol,1}}; - + {removed,"removed in 20.0; use ssl:negotiated_protocol/1 instead"}; obsolete_1(ssl, connection_info, 1) -> - {deprecated, "deprecated; use connection_information/[1,2] instead"}; + {removed, "removed in 20.0; use ssl:connection_information/[1,2] instead"}; obsolete_1(httpd_conf, check_enum, 2) -> {deprecated, "deprecated; use lists:member/2 instead"}; @@ -648,6 +580,37 @@ obsolete_1(httpd_conf, is_file, 1) -> obsolete_1(httpd_conf, make_integer, 1) -> {deprecated, "deprecated; use erlang:list_to_integer/1 instead"}; +%% Added in OTP 19. + +obsolete_1(random, _, _) -> + {deprecated, "the 'random' module is deprecated; " + "use the 'rand' module instead"}; +obsolete_1(code, rehash, 0) -> + {deprecated, "deprecated because the code path cache feature has been removed"}; +obsolete_1(queue, lait, 1) -> + {deprecated, {queue,liat,1}}; + +%% Removed in OTP 19. + +obsolete_1(overload, _, _) -> + {removed, "removed in OTP 19"}; +obsolete_1(rpc, safe_multi_server_call, A) when A =:= 2; A =:= 3 -> + {removed, {rpc, multi_server_call, A}, "removed in OTP 19"}; + +%% Added in OTP 20. + +obsolete_1(filename, find_src, 1) -> + {deprecated, "deprecated; use filelib:find_source/1 instead"}; +obsolete_1(filename, find_src, 2) -> + {deprecated, "deprecated; use filelib:find_source/3 instead"}; + +%% Removed in OTP 20. + +obsolete_1(erlang, hash, 2) -> + {removed, {erlang, phash2, 2}, "20.0"}; + +%% not obsolete + obsolete_1(_, _, _) -> no. @@ -695,29 +658,29 @@ is_snmp_agent_function(del_agent_caps, 1) -> true; is_snmp_agent_function(get_agent_caps, 0) -> true; is_snmp_agent_function(_, _) -> false. +-dialyzer({no_match, obsolete_type/3}). + -spec obsolete_type(module(), atom(), arity()) -> 'no' | {tag(), string()} | {tag(), mfas(), release()}. +-dialyzer({no_match, obsolete_type/3}). obsolete_type(Module, Name, NumberOfVariables) -> case obsolete_type_1(Module, Name, NumberOfVariables) of -%% {deprecated=Tag,{_,_,_}=Replacement} -> -%% {Tag,Replacement,"in a future release"}; + {deprecated=Tag,{_,_,_}=Replacement} -> + {Tag,Replacement,"in a future release"}; {_,String}=Ret when is_list(String) -> Ret; -%% {_,_,_}=Ret -> -%% Ret; + {_,_,_}=Ret -> + Ret; no -> no end. obsolete_type_1(erl_scan,column,0) -> - {deprecated, - "deprecated (will be removed in OTP 19); use erl_anno:column() instead"}; + {removed,{erl_anno,column,0},"19.0"}; obsolete_type_1(erl_scan,line,0) -> - {deprecated, - "deprecated (will be removed in OTP 19); use erl_anno:line() instead"}; + {removed,{erl_anno,line,0},"19.0"}; obsolete_type_1(erl_scan,location,0) -> - {deprecated, - "deprecated (will be removed in OTP 19); use erl_anno:location() instead"}; + {removed,{erl_anno,location,0},"19.0"}; obsolete_type_1(_,_,_) -> no. diff --git a/lib/stdlib/src/pool.erl b/lib/stdlib/src/pool.erl index 2112337f65..05950a1d7c 100644 --- a/lib/stdlib/src/pool.erl +++ b/lib/stdlib/src/pool.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2013. All Rights Reserved. +%% Copyright Ericsson AB 1996-2016. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. diff --git a/lib/stdlib/src/proc_lib.erl b/lib/stdlib/src/proc_lib.erl index bbf4f573f5..8e10cbe93b 100644 --- a/lib/stdlib/src/proc_lib.erl +++ b/lib/stdlib/src/proc_lib.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2014. All Rights Reserved. +%% Copyright Ericsson AB 1996-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -30,7 +30,8 @@ start/3, start/4, start/5, start_link/3, start_link/4, start_link/5, hibernate/3, init_ack/1, init_ack/2, - init_p/3,init_p/5,format/1,format/2,initial_call/1, + init_p/3,init_p/5,format/1,format/2,format/3, + initial_call/1, translate_initial_call/1, stop/1, stop/3]). @@ -42,12 +43,19 @@ %%----------------------------------------------------------------------------- -type priority_level() :: 'high' | 'low' | 'max' | 'normal'. +-type max_heap_size() :: non_neg_integer() | + #{ size => non_neg_integer(), + kill => true, + error_logger => true}. -type spawn_option() :: 'link' | 'monitor' | {'priority', priority_level()} + | {'max_heap_size', max_heap_size()} | {'min_heap_size', non_neg_integer()} | {'min_bin_vheap_size', non_neg_integer()} - | {'fullsweep_after', non_neg_integer()}. + | {'fullsweep_after', non_neg_integer()} + | {'message_queue_data', + 'off_heap' | 'on_heap' | 'mixed' }. -type dict_or_pid() :: pid() | (ProcInfo :: [_]) @@ -224,7 +232,7 @@ init_p(Parent, Ancestors, Fun) when is_function(Fun) -> Fun() catch Class:Reason -> - exit_p(Class, Reason) + exit_p(Class, Reason, erlang:get_stacktrace()) end. -spec init_p(pid(), [pid()], atom(), atom(), [term()]) -> term(). @@ -239,7 +247,7 @@ init_p_do_apply(M, F, A) -> apply(M, F, A) catch Class:Reason -> - exit_p(Class, Reason) + exit_p(Class, Reason, erlang:get_stacktrace()) end. -spec wake_up(atom(), atom(), [term()]) -> term(). @@ -249,22 +257,29 @@ wake_up(M, F, A) when is_atom(M), is_atom(F), is_list(A) -> apply(M, F, A) catch Class:Reason -> - exit_p(Class, Reason) + exit_p(Class, Reason, erlang:get_stacktrace()) end. -exit_p(Class, Reason) -> +exit_p(Class, Reason, Stacktrace) -> case get('$initial_call') of {M,F,A} when is_atom(M), is_atom(F), is_integer(A) -> MFA = {M,F,make_dummy_args(A, [])}, - crash_report(Class, Reason, MFA), - exit(Reason); + crash_report(Class, Reason, MFA, Stacktrace), + erlang:raise(exit, exit_reason(Class, Reason, Stacktrace), Stacktrace); _ -> %% The process dictionary has been cleared or %% possibly modified. - crash_report(Class, Reason, []), - exit(Reason) + crash_report(Class, Reason, [], Stacktrace), + erlang:raise(exit, exit_reason(Class, Reason, Stacktrace), Stacktrace) end. +exit_reason(error, Reason, Stacktrace) -> + {Reason, Stacktrace}; +exit_reason(exit, Reason, _Stacktrace) -> + Reason; +exit_reason(throw, Reason, Stacktrace) -> + {{nocatch, Reason}, Stacktrace}. + -spec start(Module, Function, Args) -> Ret when Module :: module(), Function :: atom(), @@ -471,16 +486,12 @@ trans_init(gen,init_it,[gen_server,_,_,supervisor_bridge,[Module|_],_]) -> {supervisor_bridge,Module,1}; trans_init(gen,init_it,[gen_server,_,_,_,supervisor_bridge,[Module|_],_]) -> {supervisor_bridge,Module,1}; -trans_init(gen,init_it,[gen_server,_,_,Module,_,_]) -> - {Module,init,1}; -trans_init(gen,init_it,[gen_server,_,_,_,Module|_]) -> - {Module,init,1}; -trans_init(gen,init_it,[gen_fsm,_,_,Module,_,_]) -> - {Module,init,1}; -trans_init(gen,init_it,[gen_fsm,_,_,_,Module|_]) -> - {Module,init,1}; trans_init(gen,init_it,[gen_event|_]) -> {gen_event,init_it,6}; +trans_init(gen,init_it,[_GenMod,_,_,Module,_,_]) when is_atom(Module) -> + {Module,init,1}; +trans_init(gen,init_it,[_GenMod,_,_,_,Module|_]) when is_atom(Module) -> + {Module,init,1}; trans_init(M, F, A) when is_atom(M), is_atom(F) -> {M,F,length(A)}. @@ -488,26 +499,28 @@ trans_init(M, F, A) when is_atom(M), is_atom(F) -> %% Generate a crash report. %% ----------------------------------------------------- -crash_report(exit, normal, _) -> ok; -crash_report(exit, shutdown, _) -> ok; -crash_report(exit, {shutdown,_}, _) -> ok; -crash_report(Class, Reason, StartF) -> - OwnReport = my_info(Class, Reason, StartF), +crash_report(exit, normal, _, _) -> ok; +crash_report(exit, shutdown, _, _) -> ok; +crash_report(exit, {shutdown,_}, _, _) -> ok; +crash_report(Class, Reason, StartF, Stacktrace) -> + OwnReport = my_info(Class, Reason, StartF, Stacktrace), LinkReport = linked_info(self()), Rep = [OwnReport,LinkReport], error_logger:error_report(crash_report, Rep). -my_info(Class, Reason, []) -> - my_info_1(Class, Reason); -my_info(Class, Reason, StartF) -> - [{initial_call, StartF}|my_info_1(Class, Reason)]. +my_info(Class, Reason, [], Stacktrace) -> + my_info_1(Class, Reason, Stacktrace); +my_info(Class, Reason, StartF, Stacktrace) -> + [{initial_call, StartF}| + my_info_1(Class, Reason, Stacktrace)]. -my_info_1(Class, Reason) -> +my_info_1(Class, Reason, Stacktrace) -> [{pid, self()}, get_process_info(self(), registered_name), - {error_info, {Class,Reason,erlang:get_stacktrace()}}, + {error_info, {Class,Reason,Stacktrace}}, get_ancestors(self()), - get_process_info(self(), messages), + get_process_info(self(), message_queue_len), + get_messages(self()), get_process_info(self(), links), get_cleaned_dictionary(self()), get_process_info(self(), trap_exit), @@ -527,12 +540,49 @@ get_ancestors(Pid) -> {ancestors,[]} end. +%% The messages and the dictionary are possibly limited too much if +%% some error handles output the messages or the dictionary using ~P +%% or ~W with depth greater than the depth used here (the depth of +%% control characters P and W takes precedence over the depth set by +%% application variable error_logger_format_depth). However, it is +%% assumed that all report handlers call proc_lib:format(). +get_messages(Pid) -> + Messages = get_process_messages(Pid), + {messages, error_logger:limit_term(Messages)}. + +get_process_messages(Pid) -> + Depth = error_logger:get_format_depth(), + case Pid =/= self() orelse Depth =:= unlimited of + true -> + {messages, Messages} = get_process_info(Pid, messages), + Messages; + false -> + %% If there are more messages than Depth, garbage + %% collection can sometimes be avoided by collecting just + %% enough messages for the crash report. It is assumed the + %% process is about to die anyway. + receive_messages(Depth) + end. + +receive_messages(0) -> []; +receive_messages(N) -> + receive + M -> + [M|receive_messages(N - 1)] + after 0 -> + [] + end. + get_cleaned_dictionary(Pid) -> case get_process_info(Pid,dictionary) of - {dictionary,Dict} -> {dictionary,clean_dict(Dict)}; + {dictionary,Dict} -> {dictionary,cleaned_dict(Dict)}; _ -> {dictionary,[]} end. +cleaned_dict(Dict) -> + CleanDict = clean_dict(Dict), + error_logger:limit_term(CleanDict). + clean_dict([{'$ancestors',_}|Dict]) -> clean_dict(Dict); clean_dict([{'$initial_call',_}|Dict]) -> @@ -570,20 +620,24 @@ make_neighbour_reports1([P|Ps]) -> make_neighbour_reports1([]) -> []. +%% Do not include messages or process dictionary, even if +%% error_logger_format_depth is unlimited. make_neighbour_report(Pid) -> [{pid, Pid}, get_process_info(Pid, registered_name), get_initial_call(Pid), get_process_info(Pid, current_function), get_ancestors(Pid), - get_process_info(Pid, messages), + get_process_info(Pid, message_queue_len), + %% get_messages(Pid), get_process_info(Pid, links), - get_cleaned_dictionary(Pid), + %% get_cleaned_dictionary(Pid), get_process_info(Pid, trap_exit), get_process_info(Pid, status), get_process_info(Pid, heap_size), get_process_info(Pid, stack_size), - get_process_info(Pid, reductions) + get_process_info(Pid, reductions), + get_process_info(Pid, current_stacktrace) ]. get_initial_call(Pid) -> @@ -700,53 +754,91 @@ format(CrashReport) -> CrashReport :: [term()], Encoding :: latin1 | unicode | utf8. -format([OwnReport,LinkReport], Encoding) -> - OwnFormat = format_report(OwnReport, Encoding), - LinkFormat = format_report(LinkReport, Encoding), +format(CrashReport, Encoding) -> + format(CrashReport, Encoding, unlimited). + +-spec format(CrashReport, Encoding, Depth) -> string() when + CrashReport :: [term()], + Encoding :: latin1 | unicode | utf8, + Depth :: unlimited | pos_integer(). + +format([OwnReport,LinkReport], Encoding, Depth) -> + Extra = {Encoding,Depth}, + MyIndent = " ", + OwnFormat = format_report(OwnReport, MyIndent, Extra), + LinkFormat = format_link_report(LinkReport, MyIndent, Extra), Str = io_lib:format(" crasher:~n~ts neighbours:~n~ts", [OwnFormat, LinkFormat]), lists:flatten(Str). -format_report(Rep, Enc) when is_list(Rep) -> - format_rep(Rep,Enc); -format_report(Rep, Enc) -> - io_lib:format("~"++modifier(Enc)++"p~n", [Rep]). - -format_rep([{initial_call,InitialCall}|Rep], Enc) -> - [format_mfa(InitialCall)|format_rep(Rep, Enc)]; -format_rep([{error_info,{Class,Reason,StackTrace}}|Rep], Enc) -> - [format_exception(Class, Reason, StackTrace, Enc)|format_rep(Rep, Enc)]; -format_rep([{Tag,Data}|Rep], Enc) -> - [format_tag(Tag, Data)|format_rep(Rep, Enc)]; -format_rep(_, _Enc) -> +format_link_report([Link|Reps], Indent, Extra) -> + Rep = case Link of + {neighbour,Rep0} -> Rep0; + _ -> Link + end, + LinkIndent = [" ",Indent], + [Indent,"neighbour:\n",format_report(Rep, LinkIndent, Extra)| + format_link_report(Reps, Indent, Extra)]; +format_link_report(Rep, Indent, Extra) -> + format_report(Rep, Indent, Extra). + +format_report(Rep, Indent, Extra) when is_list(Rep) -> + format_rep(Rep, Indent, Extra); +format_report(Rep, Indent, {Enc,unlimited}) -> + io_lib:format("~s~"++modifier(Enc)++"p~n", [Indent, Rep]); +format_report(Rep, Indent, {Enc,Depth}) -> + io_lib:format("~s~"++modifier(Enc)++"P~n", [Indent, Rep, Depth]). + +format_rep([{initial_call,InitialCall}|Rep], Indent, Extra) -> + [format_mfa(Indent, InitialCall, Extra)|format_rep(Rep, Indent, Extra)]; +format_rep([{error_info,{Class,Reason,StackTrace}}|Rep], Indent, Extra) -> + [format_exception(Class, Reason, StackTrace, Extra)| + format_rep(Rep, Indent, Extra)]; +format_rep([{Tag,Data}|Rep], Indent, Extra) -> + [format_tag(Indent, Tag, Data, Extra)|format_rep(Rep, Indent, Extra)]; +format_rep(_, _, _Extra) -> []. -format_exception(Class, Reason, StackTrace, Enc) -> - PF = pp_fun(Enc), +format_exception(Class, Reason, StackTrace, {Enc,_}=Extra) -> + PF = pp_fun(Extra), StackFun = fun(M, _F, _A) -> (M =:= erl_eval) or (M =:= ?MODULE) end, %% EI = " exception: ", EI = " ", [EI, lib:format_exception(1+length(EI), Class, Reason, StackTrace, StackFun, PF, Enc), "\n"]. -format_mfa({M,F,Args}=StartF) -> +format_mfa(Indent, {M,F,Args}=StartF, {Enc,_}=Extra) -> try A = length(Args), - [" initial call: ",atom_to_list(M),$:,atom_to_list(F),$/, + [Indent,"initial call: ",atom_to_list(M),$:,to_string(F, Enc),$/, integer_to_list(A),"\n"] catch error:_ -> - format_tag(initial_call, StartF) + format_tag(Indent, initial_call, StartF, Extra) end. -pp_fun(Enc) -> - P = modifier(Enc) ++ "p", +to_string(A, latin1) -> + io_lib:write_atom_as_latin1(A); +to_string(A, _) -> + io_lib:write_atom(A). + +pp_fun({Enc,Depth}) -> + {P,Tl} = p(Enc, Depth), fun(Term, I) -> - io_lib:format("~." ++ integer_to_list(I) ++ P, [Term]) + io_lib:format("~." ++ integer_to_list(I) ++ P, [Term|Tl]) end. -format_tag(Tag, Data) -> - io_lib:format(" ~p: ~80.18p~n", [Tag, Data]). +format_tag(Indent, Tag, Data, {Enc,Depth}) -> + {P,Tl} = p(Enc, Depth), + io_lib:format("~s~p: ~80.18" ++ P ++ "\n", [Indent, Tag, Data|Tl]). + +p(Encoding, Depth) -> + {Letter, Tl} = case Depth of + unlimited -> {"p", []}; + _ -> {"P", [Depth]} + end, + P = modifier(Encoding) ++ Letter, + {P, Tl}. modifier(latin1) -> ""; modifier(_) -> "t". diff --git a/lib/stdlib/src/proplists.erl b/lib/stdlib/src/proplists.erl index 1840fa5cc0..340dfdcac9 100644 --- a/lib/stdlib/src/proplists.erl +++ b/lib/stdlib/src/proplists.erl @@ -1,8 +1,3 @@ -%% -%% %CopyrightBegin% -%% -%% Copyright Ericsson AB 2001-2013. All Rights Reserved. -%% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. %% You may obtain a copy of the License at @@ -15,14 +10,8 @@ %% See the License for the specific language governing permissions and %% limitations under the License. %% -%% %CopyrightEnd% -%% -%% ===================================================================== -%% Support functions for property lists -%% -%% Copyright (C) 2000-2003 Richard Carlsson -%% --------------------------------------------------------------------- -%% +%% @copyright 2000-2003 Richard Carlsson +%% @author Richard Carlsson <[email protected]> %% @doc Support functions for property lists. %% %% <p>Property lists are ordinary lists containing entries in the form @@ -94,7 +83,7 @@ property(Key, Value) -> %% --------------------------------------------------------------------- -%% @doc Unfolds all occurences of atoms in <code>ListIn</code> to tuples +%% @doc Unfolds all occurrences of atoms in <code>ListIn</code> to tuples %% <code>{Atom, true}</code>. %% %% @see compact/1 @@ -438,8 +427,9 @@ substitute_aliases_1([], P) -> %% @see normalize/2 -spec substitute_negations(Negations, ListIn) -> ListOut when - Negations :: [{Key, Key}], - Key :: term(), + Negations :: [{Key1, Key2}], + Key1 :: term(), + Key2 :: term(), ListIn :: [term()], ListOut :: [term()]. diff --git a/lib/stdlib/src/qlc.erl b/lib/stdlib/src/qlc.erl index 3ba3a88038..f11f9d0a0b 100644 --- a/lib/stdlib/src/qlc.erl +++ b/lib/stdlib/src/qlc.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2004-2015. All Rights Reserved. +%% Copyright Ericsson AB 2004-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -51,6 +51,8 @@ -export([template_state/0, aux_name/3, name_suffix/2, vars/1, var_ufold/2, var_fold/3, all_selections/1]). +-dialyzer(no_improper_lists). + %% When cache=list lists bigger than ?MAX_LIST_SIZE bytes are put on %% file. Also used when merge join finds big equivalence classes. -define(MAX_LIST_SIZE, 512*1024). @@ -633,14 +635,25 @@ string_to_handle(Str, Options, Bindings) when is_list(Str) -> badarg -> erlang:error(badarg, [Str, Options, Bindings]); [Unique, Cache, MaxLookup, Join, Lookup] -> - case erl_scan:string(Str) of + case erl_scan:string(Str, 1, [text]) of {ok, Tokens, _} -> - case erl_parse:parse_exprs(Tokens) of - {ok, [Expr]} -> - case qlc_pt:transform_expression(Expr, Bindings) of + ScanRes = + case lib:extended_parse_exprs(Tokens) of + {ok, [Expr0], SBs} -> + {ok, Expr0, SBs}; + {ok, _ExprList, _SBs} -> + erlang:error(badarg, + [Str, Options, Bindings]); + E -> + E + end, + case ScanRes of + {ok, Expr, XBs} -> + Bs1 = merge_binding_structs(Bindings, XBs), + case qlc_pt:transform_expression(Expr, Bs1) of {ok, {call, _, _QlcQ, Handle}} -> {value, QLC_lc, _} = - erl_eval:exprs(Handle, Bindings), + erl_eval:exprs(Handle, Bs1), O = #qlc_opt{unique = Unique, cache = Cache, max_lookup = MaxLookup, @@ -650,8 +663,6 @@ string_to_handle(Str, Options, Bindings) when is_list(Str) -> {not_ok, [{error, Error} | _]} -> error(Error) end; - {ok, _ExprList} -> - erlang:error(badarg, [Str, Options, Bindings]); {error, ErrorInfo} -> error(ErrorInfo) end; @@ -732,10 +743,11 @@ table(TraverseFun, Options) when is_function(TraverseFun) -> table(T1, T2) -> erlang:error(badarg, [T1, T2]). --spec(transform_from_evaluator(LC, Bs) -> Expr when +-spec(transform_from_evaluator(LC, Bs) -> Return when LC :: abstract_expr(), - Expr :: abstract_expr(), - Bs :: erl_eval:binding_struct()). + Bs :: erl_eval:binding_struct(), + Return :: {ok, abstract_expr()} + | {not_ok, {error, module(), Reason :: term()}}). transform_from_evaluator(LC, Bs0) -> qlc_pt:transform_from_evaluator(LC, Bs0). @@ -767,6 +779,10 @@ all_selections([{I,Cs} | ICs]) -> %%% Local functions %%% +merge_binding_structs(Bs1, Bs2) -> + lists:foldl(fun({N, V}, Bs) -> erl_eval:add_binding(N, V, Bs) + end, Bs1, erl_eval:bindings(Bs2)). + aux_name1(Name, N, AllNames) -> SN = name_suffix(Name, N), case sets:is_element(SN, AllNames) of @@ -808,21 +824,21 @@ options(Options0, [Key | Keys], L) when is_list(Options0) -> {ok, U}; {pre_fun, U=undefined} -> {ok, U}; - {info_fun, Fun} when is_function(Fun), is_function(Fun, 1) -> + {info_fun, Fun} when is_function(Fun, 1) -> {ok, Fun}; - {pre_fun, Fun} when is_function(Fun), is_function(Fun, 1) -> + {pre_fun, Fun} when is_function(Fun, 1) -> {ok, Fun}; - {post_fun, Fun} when is_function(Fun), is_function(Fun, 0) -> + {post_fun, Fun} when is_function(Fun, 0) -> {ok, Fun}; - {lookup_fun, Fun} when is_function(Fun), is_function(Fun, 2) -> + {lookup_fun, Fun} when is_function(Fun, 2) -> {ok, Fun}; {max_lookup, Max} when is_integer(Max), Max >= 0 -> {ok, Max}; {max_lookup, infinity} -> {ok, -1}; - {format_fun, Fun} when is_function(Fun), is_function(Fun, 1) -> + {format_fun, Fun} when is_function(Fun, 1) -> {ok, Fun}; - {parent_fun, Fun} when is_function(Fun), is_function(Fun, 0) -> + {parent_fun, Fun} when is_function(Fun, 0) -> {ok, Fun}; {key_equality, KE='=='} -> {ok, KE}; @@ -885,7 +901,7 @@ options(Options0, [Key | Keys], L) when is_list(Options0) -> {depth, Depth} when Depth =:= infinity; is_integer(Depth), Depth >= 0 -> {ok, Depth}; - {order, Order} when is_function(Order), is_function(Order, 2); + {order, Order} when is_function(Order, 2); (Order =:= ascending); (Order =:= descending) -> {ok, Order}; @@ -1116,7 +1132,7 @@ wait_for_request(Parent, MonRef, Post) -> wait_for_request(Parent, MonRef, Post); Other -> error_logger:error_msg( - "The qlc cursor ~w received an unexpected message:\n~p\n", + "The qlc cursor ~w received an unexpected message:\n~tp\n", [self(), Other]), wait_for_request(Parent, MonRef, Post) end. @@ -1177,9 +1193,12 @@ abstract1({table, {M, F, As0}}, _NElements, _Depth, Anno) abstract1({table, TableDesc}, _NElements, _Depth, _A) -> case io_lib:deep_char_list(TableDesc) of true -> - {ok, Tokens, _} = erl_scan:string(lists:flatten(TableDesc++".")), - {ok, [Expr]} = erl_parse:parse_exprs(Tokens), - Expr; + {ok, Tokens, _} = + erl_scan:string(lists:flatten(TableDesc++"."), 1, [text]), + {ok, Es, Bs} = + lib:extended_parse_exprs(Tokens), + [Expr] = lib:subst_values_for_vars(Es, Bs), + special(Expr); false -> % abstract expression TableDesc end; @@ -1207,6 +1226,15 @@ abstract1({list, L}, NElements, Depth, _A) when NElements =:= infinity; abstract1({list, L}, NElements, Depth, _A) -> abstract_term(depth(lists:sublist(L, NElements), Depth) ++ '...', 1). +special({value, _, Thing}) -> + abstract_term(Thing); +special(Tuple) when is_tuple(Tuple) -> + list_to_tuple(special(tuple_to_list(Tuple))); +special([E|Es]) -> + [special(E)|special(Es)]; +special(Expr) -> + Expr. + depth(List, infinity) -> List; depth(List, Depth) -> @@ -1289,6 +1317,10 @@ abstr_term(Fun, Line) when is_function(Fun) -> end; abstr_term(PPR, Line) when is_pid(PPR); is_port(PPR); is_reference(PPR) -> {special, Line, lists:flatten(io_lib:write(PPR))}; +abstr_term(Map, Line) when is_map(Map) -> + {map,Line, + [{map_field_assoc,Line,abstr_term(K, Line),abstr_term(V, Line)} || + {K,V} <- maps:to_list(Map)]}; abstr_term(Simple, Line) -> erl_parse:abstract(Simple, erl_anno:line(Line)). @@ -1360,8 +1392,10 @@ next_loop(Pid, L, N) when N =/= 0 -> {caught, throw, Error, [?THROWN_ERROR | _]} -> Error; {caught, Class, Reason, Stacktrace} -> - _ = (catch erlang:error(foo)), - erlang:raise(Class, Reason, Stacktrace ++ erlang:get_stacktrace()); + CurrentStacktrace = try erlang:error(foo) + catch error:_ -> erlang:get_stacktrace() + end, + erlang:raise(Class, Reason, Stacktrace ++ CurrentStacktrace); error -> erlang:error({qlc_cursor_pid_no_longer_exists, Pid}) end; diff --git a/lib/stdlib/src/qlc_pt.erl b/lib/stdlib/src/qlc_pt.erl index 4e81e2c2dd..4a39f8ae9d 100644 --- a/lib/stdlib/src/qlc_pt.erl +++ b/lib/stdlib/src/qlc_pt.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2004-2015. All Rights Reserved. +%% Copyright Ericsson AB 2004-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -41,6 +41,7 @@ }). -record(state, {imp, + overridden, maxargs, records, xwarnings = [], @@ -67,8 +68,8 @@ %%% -spec(parse_transform(Forms, Options) -> Forms2 when - Forms :: [erl_parse:abstract_form()], - Forms2 :: [erl_parse:abstract_form()], + Forms :: [erl_parse:abstract_form() | erl_parse:form_info()], + Forms2 :: [erl_parse:abstract_form() | erl_parse:form_info()], Options :: [Option], Option :: type_checker | compile:option()). @@ -117,19 +118,21 @@ parse_transform(Forms0, Options) -> true = ets:delete(NodeInfo) end. --spec(transform_from_evaluator(LC, Bs) -> Expr when +-spec(transform_from_evaluator(LC, Bs) -> Return when LC :: erl_parse:abstract_expr(), - Expr :: erl_parse:abstract_expr(), - Bs :: erl_eval:binding_struct()). + Bs :: erl_eval:binding_struct(), + Return :: {ok, erl_parse:abstract_expr()} + | {not_ok, {error, module(), Reason :: term()}}). transform_from_evaluator(LC, Bindings) -> ?DEBUG("qlc Parse Transform (Evaluator Version)~n", []), transform_expression(LC, Bindings, false). --spec(transform_expression(LC, Bs) -> Expr when +-spec(transform_expression(LC, Bs) -> Return when LC :: erl_parse:abstract_expr(), - Expr :: erl_parse:abstract_expr(), - Bs :: erl_eval:binding_struct()). + Bs :: erl_eval:binding_struct(), + Return :: {ok, erl_parse:abstract_expr()} + | {not_ok, [{error, Reason :: term()}]}). transform_expression(LC, Bindings) -> transform_expression(LC, Bindings, true). @@ -182,7 +185,9 @@ initiate(Forms0, Imported) -> exclude_integers_from_unique_line_numbers(Forms0, NodeInfo), ?DEBUG("node info0 ~p~n", [lists:sort(ets:tab2list(NodeInfo))]), + IsOverridden = set_up_overridden(Forms0), State0 = #state{imp = Imported, + overridden = IsOverridden, maxargs = ?EVAL_MAX_NUM_OF_ARGS, records = record_attributes(Forms0), node_info = NodeInfo}, @@ -200,7 +205,7 @@ exclude_integers_from_unique_line_numbers(Forms, NodeInfo) -> find_integers(Forms) -> F = fun(A) -> - Fs1 = erl_parse:map_anno(fun(_) -> A end, Forms), + Fs1 = map_anno(fun(_) -> A end, Forms), ordsets:from_list(integers(Fs1, [])) end, ordsets:to_list(ordsets:intersection(F(anno0()), F(anno1()))). @@ -319,13 +324,13 @@ badarg(Forms, State) -> E0. lc_nodes(E, NodeInfo) -> - erl_parse:map_anno(fun(Anno) -> - N = erl_anno:line(Anno), - [{N, Data}] = ets:lookup(NodeInfo, N), - NData = Data#{inside_lc => true}, - true = ets:insert(NodeInfo, {N, NData}), - Anno - end, E). + map_anno(fun(Anno) -> + N = erl_anno:line(Anno), + [{N, Data}] = ets:lookup(NodeInfo, N), + NData = Data#{inside_lc => true}, + true = ets:insert(NodeInfo, {N, NData}), + Anno + end, E). used_genvar_messages(MsL, S) -> [{File,[{Loc,?APIMOD,{used_generator_variable,V}}]} @@ -416,7 +421,7 @@ intro_anno(LC, Where, QId, NodeInfo) -> true = ets:insert(NodeInfo, {Location,Data}), Anno end, - erl_parse:map_anno(Fun, save_anno(LC, NodeInfo)). + map_anno(Fun, save_anno(LC, NodeInfo)). compile_errors(FormsNoShadows) -> case compile_forms(FormsNoShadows, []) of @@ -428,7 +433,13 @@ compile_errors(FormsNoShadows) -> end. compile_forms(Forms0, Options) -> - Forms = [F || F <- Forms0, element(1, F) =/= eof] ++ [{eof,anno0()}], + Exclude = fun(eof) -> true; + (warning) -> true; + (error) -> true; + (_) -> false + end, + Forms = ([F || F <- Forms0, not Exclude(element(1, F))] + ++ [{eof,0}]), try case compile:noenv_forms(Forms, compile_options(Options)) of {ok, _ModName, Ws0} -> @@ -1511,36 +1522,35 @@ filter_info(FilterData, AllIVs, Dependencies, State) -> %% to be placed after further generators (the docs states otherwise, but %% this seems to be common practice). filter_list(FilterData, Dependencies, State) -> - RDs = State#state.records, - sel_gf(FilterData, 1, Dependencies, RDs, [], []). + sel_gf(FilterData, 1, Dependencies, State, [], []). sel_gf([], _N, _Deps, _RDs, _Gens, _Gens1) -> []; -sel_gf([{#qid{no = N}=Id,{fil,F}}=Fil | FData], N, Deps, RDs, Gens, Gens1) -> - case erl_lint:is_guard_test(F, RDs) of +sel_gf([{#qid{no = N}=Id,{fil,F}}=Fil | FData], N, Deps, State, Gens, Gens1) -> + case is_guard_test(F, State) of true -> {Id,GIds} = lists:keyfind(Id, 1, Deps), case length(GIds) =< 1 of true -> case generators_in_scope(GIds, Gens1) of true -> - [Fil|sel_gf(FData, N+1, Deps, RDs, Gens, Gens1)]; + [Fil|sel_gf(FData, N+1, Deps, State, Gens, Gens1)]; false -> - sel_gf(FData, N + 1, Deps, RDs, [], []) + sel_gf(FData, N + 1, Deps, State, [], []) end; false -> case generators_in_scope(GIds, Gens) of true -> - [Fil | sel_gf(FData, N + 1, Deps, RDs, Gens, [])]; + [Fil | sel_gf(FData, N + 1, Deps, State, Gens, [])]; false -> - sel_gf(FData, N + 1, Deps, RDs, [], []) + sel_gf(FData, N + 1, Deps, State, [], []) end end; false -> - sel_gf(FData, N + 1, Deps, RDs, [], []) + sel_gf(FData, N + 1, Deps, State, [], []) end; -sel_gf(FData, N, Deps, RDs, Gens, Gens1) -> - sel_gf(FData, N + 1, Deps, RDs, [N | Gens], [N | Gens1]). +sel_gf(FData, N, Deps, State, Gens, Gens1) -> + sel_gf(FData, N + 1, Deps, State, [N | Gens], [N | Gens1]). generators_in_scope(GenIds, GenNumbers) -> lists:all(fun(#qid{no=N}) -> lists:member(N, GenNumbers) end, GenIds). @@ -1644,7 +1654,7 @@ reset_anno(T) -> set_anno(T, anno0()). set_anno(T, A) -> - erl_parse:map_anno(fun(_L) -> A end, T). + map_anno(fun(_L) -> A end, T). -record(fstate, {state, bind_fun, imported}). @@ -1862,7 +1872,8 @@ prep_expr(E, F, S, BF, Imported) -> unify_column(Frame, Var, Col, BindFun, Imported) -> A = anno0(), - Call = {call,A,{atom,A,element},[{integer,A,Col}, {var,A,Var}]}, + Call = {call,A,{remote,A,{atom,A,erlang},{atom,A,element}}, + [{integer,A,Col}, {var,A,Var}]}, element_calls(Call, Frame, BindFun, Imported). %% cons_tuple is used for representing {V1, ..., Vi | TupleTail}. @@ -1872,6 +1883,8 @@ unify_column(Frame, Var, Col, BindFun, Imported) -> %% about the size of the tuple is known. element_calls({call,_,{remote,_,{atom,_,erlang},{atom,_,element}}, [{integer,_,I},Term0]}, F0, BF, Imported) when I > 0 -> + %% Note: erl_expand_records ensures that all calls to element/2 + %% have an explicit "erlang:" prefix. TupleTail = unique_var(), VarsL = [unique_var() || _ <- lists:seq(1, I)], Vars = VarsL ++ TupleTail, @@ -1879,10 +1892,6 @@ element_calls({call,_,{remote,_,{atom,_,erlang},{atom,_,element}}, VarI = lists:nth(I, VarsL), {Term, F} = element_calls(Term0, F0, BF, Imported), {VarI, unify('=:=', Tuple, Term, F, BF, Imported)}; -element_calls({call,L1,{atom,_,element}=E,As}, F0, BF, Imported) -> - %% erl_expand_records should add "erlang:"... - element_calls({call,L1,{remote,L1,{atom,L1,erlang},E}, As}, F0, BF, - Imported); element_calls(T, F0, BF, Imported) when is_tuple(T) -> {L, F} = element_calls(tuple_to_list(T), F0, BF, Imported), {list_to_tuple(L), F}; @@ -1908,9 +1917,9 @@ expand_pattern_records(P, State) -> expand_expr_records(E, State) -> RecordDefs = State#state.records, A = anno1(), - Forms = RecordDefs ++ [{function,A,foo,0,[{clause,A,[],[],[pe(E)]}]}], - [{function,_,foo,0,[{clause,_,[],[],[NE]}]}] = - erl_expand_records:module(Forms, [no_strict_record_tests]), + Forms0 = RecordDefs ++ [{function,A,foo,0,[{clause,A,[],[],[pe(E)]}]}], + Forms = erl_expand_records:module(Forms0, [no_strict_record_tests]), + {function,_,foo,0,[{clause,_,[],[],[NE]}]} = lists:last(Forms), NE. %% Partial evaluation. @@ -2476,7 +2485,7 @@ filter(E, L, QIVs, S, RL, Fun, Go, GoI, IVs, State) -> %% This is the "guard semantics" used in ordinary list %% comprehension: if a filter looks like a guard test, it returns %% 'false' rather than fails. - Body = case erl_lint:is_guard_test(E, State#state.records) of + Body = case is_guard_test(E, State) of true -> CT = {clause,L,[],[[E]],[{call,L,?V(Fun),NAsT}]}, CF = {clause,L,[],[[?A(true)]],[{call,L,?V(Fun),NAsF}]}, @@ -2603,7 +2612,7 @@ save_anno(Abstr, NodeInfo) -> true = ets:insert(NodeInfo, Data), erl_anno:new(N) end, - erl_parse:map_anno(F, Abstr). + map_anno(F, Abstr). next_slot(T) -> I = ets:update_counter(T, var_n, 1), @@ -2627,7 +2636,7 @@ restore_anno(Abstr, NodeInfo) -> Anno end end, - erl_parse:map_anno(F, Abstr). + map_anno(F, Abstr). restore_loc(Location, #state{node_info = NodeInfo}) -> case ets:lookup(NodeInfo, Location) of @@ -2866,12 +2875,40 @@ var_mapfold(F, A0, [E0 | Es0]) -> var_mapfold(_F, A, E) -> {E, A}. +map_anno(F, AbstrList) when is_list(AbstrList) -> + [map_anno1(F, Abstr) || Abstr <- AbstrList]; +map_anno(F, Abstr) -> + map_anno1(F, Abstr). + +map_anno1(F, Abstr) -> + erl_parse:map_anno(F, Abstr). + family_list(L) -> sofs:to_external(family(L)). family(L) -> sofs:relation_to_family(sofs:relation(L)). +is_guard_test(E, #state{records = RDs, overridden = IsOverridden}) -> + erl_lint:is_guard_test(E, RDs, IsOverridden). + +%% In code that has been run through erl_expand_records, a guard +%% test will never contain calls without an explicit module +%% prefix. Unfortunately, this module runs *some* of the code +%% through erl_expand_records, but not all of it. +%% +%% Therefore, we must set up our own list of local and imported functions +%% that will override a BIF with the same name. + +set_up_overridden(Forms) -> + Locals = [{Name,Arity} || {function,_,Name,Arity,_} <- Forms], + Imports0 = [Fs || {attribute,_,import,Fs} <- Forms], + Imports1 = lists:flatten(Imports0), + Imports2 = [Fs || {_,Fs} <- Imports1], + Imports = lists:flatten(Imports2), + Overridden = gb_sets:from_list(Imports ++ Locals), + fun(FA) -> gb_sets:is_element(FA, Overridden) end. + -ifdef(debug). display_forms(Forms) -> io:format("Forms ***~n"), diff --git a/lib/stdlib/src/queue.erl b/lib/stdlib/src/queue.erl index 2e65759d2a..11c0aa8d2b 100644 --- a/lib/stdlib/src/queue.erl +++ b/lib/stdlib/src/queue.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2014. All Rights Reserved. +%% Copyright Ericsson AB 1996-2016. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -31,10 +31,14 @@ %% Okasaki API from klacke -export([cons/2,head/1,tail/1, - snoc/2,last/1,daeh/1,init/1,liat/1,lait/1]). + snoc/2,last/1,daeh/1,init/1,liat/1]). -export_type([queue/0, queue/1]). +%% Mis-spelled, deprecated. +-export([lait/1]). +-deprecated([lait/1]). + %%-------------------------------------------------------------------------- %% Efficient implementation of double ended fifo queues %% diff --git a/lib/stdlib/src/rand.erl b/lib/stdlib/src/rand.erl index 8e8d0bc801..7a8a5e6d4a 100644 --- a/lib/stdlib/src/rand.erl +++ b/lib/stdlib/src/rand.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2015. All Rights Reserved. +%% Copyright Ericsson AB 2015-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -19,7 +19,10 @@ %% %% ===================================================================== %% Multiple PRNG module for Erlang/OTP -%% Copyright (c) 2015 Kenji Rikitake +%% Copyright (c) 2015-2016 Kenji Rikitake +%% +%% exrop (xoroshiro116+) added and statistical distribution +%% improvements by the Erlang/OTP team 2017 %% ===================================================================== -module(rand). @@ -27,34 +30,180 @@ -export([seed_s/1, seed_s/2, seed/1, seed/2, export_seed/0, export_seed_s/1, uniform/0, uniform/1, uniform_s/1, uniform_s/2, - normal/0, normal_s/1 + jump/0, jump/1, + normal/0, normal/2, normal_s/1, normal_s/3 ]). -compile({inline, [exs64_next/1, exsplus_next/1, exs1024_next/1, exs1024_calc/2, + exrop_next/1, exrop_next_s/2, get_52/1, normal_kiwi/1]}). --define(DEFAULT_ALG_HANDLER, exsplus). +-define(DEFAULT_ALG_HANDLER, exrop). -define(SEED_DICT, rand_seed). %% ===================================================================== +%% Bit fiddling macros +%% ===================================================================== + +-define(BIT(Bits), (1 bsl (Bits))). +-define(MASK(Bits), (?BIT(Bits) - 1)). +-define(MASK(Bits, X), ((X) band ?MASK(Bits))). +-define( + BSL(Bits, X, N), + %% N is evaluated 2 times + (?MASK((Bits)-(N), (X)) bsl (N))). +-define( + ROTL(Bits, X, N), + %% Bits is evaluated 2 times + %% X is evaluated 2 times + %% N i evaluated 3 times + (?BSL((Bits), (X), (N)) bor ((X) bsr ((Bits)-(N))))). + +%%-define(TWO_POW_MINUS53, (math:pow(2, -53))). +-define(TWO_POW_MINUS53, 1.11022302462515657e-16). + +%% ===================================================================== %% Types %% ===================================================================== +-type uint64() :: 0..?MASK(64). +-type uint58() :: 0..?MASK(58). + %% This depends on the algorithm handler function --type alg_seed() :: exs64_state() | exsplus_state() | exs1024_state(). -%% This is the algorithm handler function within this module --type alg_handler() :: #{type => alg(), - max => integer(), - next => fun(), - uniform => fun(), - uniform_n => fun()}. - -%% Internal state --opaque state() :: {alg_handler(), alg_seed()}. --type alg() :: exs64 | exsplus | exs1024. --opaque export_state() :: {alg(), alg_seed()}. --export_type([alg/0, state/0, export_state/0]). +-type alg_state() :: + exs64_state() | exsplus_state() | exs1024_state() | + exrop_state() | term(). + +%% This is the algorithm handling definition within this module, +%% and the type to use for plugins. +%% +%% The 'type' field must be recognized by the module that implements +%% the algorithm, to interpret an exported state. +%% +%% The 'bits' field indicates how many bits the integer +%% returned from 'next' has got, i.e 'next' shall return +%% an random integer in the range 0..(2^Bits - 1). +%% At least 53 bits is required for the floating point +%% producing fallbacks. This field is only used when +%% the 'uniform' or 'uniform_n' fields are not defined. +%% +%% The fields 'next', 'uniform' and 'uniform_n' +%% implement the algorithm. If 'uniform' or 'uinform_n' +%% is not present there is a fallback using 'next' and either +%% 'bits' or the deprecated 'max'. +%% +-type alg_handler() :: + #{type := alg(), + bits => non_neg_integer(), + weak_low_bits => non_neg_integer(), + max => non_neg_integer(), % Deprecated + next := + fun ((alg_state()) -> {non_neg_integer(), alg_state()}), + uniform => + fun ((state()) -> {float(), state()}), + uniform_n => + fun ((pos_integer(), state()) -> {pos_integer(), state()}), + jump => + fun ((state()) -> state())}. + +%% Algorithm state +-type state() :: {alg_handler(), alg_state()}. +-type builtin_alg() :: exs64 | exsplus | exsp | exs1024 | exs1024s | exrop. +-type alg() :: builtin_alg() | atom(). +-type export_state() :: {alg(), alg_state()}. +-export_type( + [builtin_alg/0, alg/0, alg_handler/0, alg_state/0, + state/0, export_state/0]). +-export_type( + [exs64_state/0, exsplus_state/0, exs1024_state/0, exrop_state/0]). + +%% ===================================================================== +%% Range macro and helper +%% ===================================================================== + +-define( + uniform_range(Range, Alg, R, V, MaxMinusRange, I), + if + 0 =< (MaxMinusRange) -> + if + %% Really work saving in odd cases; + %% large ranges in particular + (V) < (Range) -> + {(V) + 1, {(Alg), (R)}}; + true -> + (I) = (V) rem (Range), + if + (V) - (I) =< (MaxMinusRange) -> + {(I) + 1, {(Alg), (R)}}; + true -> + %% V in the truncated top range + %% - try again + ?FUNCTION_NAME((Range), {(Alg), (R)}) + end + end; + true -> + uniform_range((Range), (Alg), (R), (V)) + end). + +%% For ranges larger than the algorithm bit size +uniform_range(Range, #{next:=Next, bits:=Bits} = Alg, R, V) -> + WeakLowBits = + case Alg of + #{weak_low_bits:=WLB} -> WLB; + #{} -> 0 + end, + %% Maybe waste the lowest bit(s) when shifting in new bits + Shift = Bits - WeakLowBits, + ShiftMask = bnot ?MASK(WeakLowBits), + RangeMinus1 = Range - 1, + if + (Range band RangeMinus1) =:= 0 -> % Power of 2 + %% Generate at least the number of bits for the range + {V1, R1, _} = + uniform_range( + Range bsr Bits, Next, R, V, ShiftMask, Shift, Bits), + {(V1 band RangeMinus1) + 1, {Alg, R1}}; + true -> + %% Generate a value with at least two bits more than the range + %% and try that for a fit, otherwise recurse + %% + %% Just one bit more should ensure that the generated + %% number range is at least twice the size of the requested + %% range, which would make the probability to draw a good + %% number better than 0.5. And repeating that until + %% success i guess would take 2 times statistically amortized. + %% But since the probability for fairly many attemtpts + %% is not that low, use two bits more than the range which + %% should make the probability to draw a bad number under 0.25, + %% which decreases the bad case probability a lot. + {V1, R1, B} = + uniform_range( + Range bsr (Bits - 2), Next, R, V, ShiftMask, Shift, Bits), + I = V1 rem Range, + if + (V1 - I) =< (1 bsl B) - Range -> + {I + 1, {Alg, R1}}; + true -> + %% V1 drawn from the truncated top range + %% - try again + {V2, R2} = Next(R1), + uniform_range(Range, Alg, R2, V2) + end + end. +%% +uniform_range(Range, Next, R, V, ShiftMask, Shift, B) -> + if + Range =< 1 -> + {V, R, B}; + true -> + {V1, R1} = Next(R), + %% Waste the lowest bit(s) when shifting in new bits + uniform_range( + Range bsr Shift, Next, R1, + ((V band ShiftMask) bsl Shift) bor V1, + ShiftMask, Shift, B + Shift) + end. %% ===================================================================== %% API @@ -63,12 +212,12 @@ %% Return algorithm and seed so that RNG state can be recreated with seed/1 -spec export_seed() -> undefined | export_state(). export_seed() -> - case seed_get() of + case get(?SEED_DICT) of {#{type:=Alg}, Seed} -> {Alg, Seed}; _ -> undefined end. --spec export_seed_s(state()) -> export_state(). +-spec export_seed_s(State :: state()) -> export_state(). export_seed_s({#{type:=Alg}, Seed}) -> {Alg, Seed}. %% seed(Alg) seeds RNG with runtime dependent values @@ -77,31 +226,37 @@ export_seed_s({#{type:=Alg}, Seed}) -> {Alg, Seed}. %% seed({Alg,Seed}) setup RNG with a previously exported seed %% and return the NEW state --spec seed(AlgOrExpState::alg() | export_state()) -> state(). +-spec seed( + AlgOrStateOrExpState :: builtin_alg() | state() | export_state()) -> + state(). seed(Alg) -> - R = seed_s(Alg), - _ = seed_put(R), - R. + seed_put(seed_s(Alg)). --spec seed_s(AlgOrExpState::alg() | export_state()) -> state(). -seed_s(Alg) when is_atom(Alg) -> - seed_s(Alg, {erlang:phash2([{node(),self()}]), - erlang:system_time(), - erlang:unique_integer()}); +-spec seed_s( + AlgOrStateOrExpState :: builtin_alg() | state() | export_state()) -> + state(). +seed_s({AlgHandler, _Seed} = State) when is_map(AlgHandler) -> + State; seed_s({Alg0, Seed}) -> {Alg,_SeedFun} = mk_alg(Alg0), - {Alg, Seed}. + {Alg, Seed}; +seed_s(Alg) -> + seed_s(Alg, {erlang:phash2([{node(),self()}]), + erlang:system_time(), + erlang:unique_integer()}). %% seed/2: seeds RNG with the algorithm and given values %% and returns the NEW state. --spec seed(Alg :: alg(), {integer(), integer(), integer()}) -> state(). +-spec seed( + Alg :: builtin_alg(), Seed :: {integer(), integer(), integer()}) -> + state(). seed(Alg0, S0) -> - State = seed_s(Alg0, S0), - _ = seed_put(State), - State. + seed_put(seed_s(Alg0, S0)). --spec seed_s(Alg :: alg(), {integer(), integer(), integer()}) -> state(). +-spec seed_s( + Alg :: builtin_alg(), Seed :: {integer(), integer(), integer()}) -> + state(). seed_s(Alg0, S0 = {_, _, _}) -> {Alg, Seed} = mk_alg(Alg0), AS = Seed(S0), @@ -110,10 +265,10 @@ seed_s(Alg0, S0 = {_, _, _}) -> %%% uniform/0, uniform/1, uniform_s/1, uniform_s/2 are all %%% uniformly distributed random numbers. -%% uniform/0: returns a random float X where 0.0 < X < 1.0, +%% uniform/0: returns a random float X where 0.0 =< X < 1.0, %% updating the state in the process dictionary. --spec uniform() -> X::float(). +-spec uniform() -> X :: float(). uniform() -> {X, Seed} = uniform_s(seed_get()), _ = seed_put(Seed), @@ -123,32 +278,76 @@ uniform() -> %% uniform/1 returns a random integer X where 1 =< X =< N, %% updating the state in the process dictionary. --spec uniform(N :: pos_integer()) -> X::pos_integer(). +-spec uniform(N :: pos_integer()) -> X :: pos_integer(). uniform(N) -> {X, Seed} = uniform_s(N, seed_get()), _ = seed_put(Seed), X. %% uniform_s/1: given a state, uniform_s/1 -%% returns a random float X where 0.0 < X < 1.0, +%% returns a random float X where 0.0 =< X < 1.0, %% and a new state. --spec uniform_s(state()) -> {X::float(), NewS :: state()}. +-spec uniform_s(State :: state()) -> {X :: float(), NewState :: state()}. uniform_s(State = {#{uniform:=Uniform}, _}) -> - Uniform(State). + Uniform(State); +uniform_s({#{bits:=Bits, next:=Next} = Alg, R0}) -> + {V, R1} = Next(R0), + %% Produce floats on the form N * 2^(-53) + {(V bsr (Bits - 53)) * ?TWO_POW_MINUS53, {Alg, R1}}; +uniform_s({#{max:=Max, next:=Next} = Alg, R0}) -> + {V, R1} = Next(R0), + %% Old broken algorithm with non-uniform density + {V / (Max + 1), {Alg, R1}}. + %% uniform_s/2: given an integer N >= 1 and a state, uniform_s/2 %% uniform_s/2 returns a random integer X where 1 =< X =< N, %% and a new state. --spec uniform_s(N::pos_integer(), state()) -> {X::pos_integer(), NewS::state()}. -uniform_s(N, State = {#{uniform_n:=Uniform, max:=Max}, _}) - when 0 < N, N =< Max -> - Uniform(N, State); -uniform_s(N, State0 = {#{uniform:=Uniform}, _}) - when is_integer(N), 0 < N -> - {F, State} = Uniform(State0), - {trunc(F * N) + 1, State}. +-spec uniform_s(N :: pos_integer(), State :: state()) -> + {X :: pos_integer(), NewState :: state()}. +uniform_s(N, State = {#{uniform_n:=UniformN}, _}) + when is_integer(N), 1 =< N -> + UniformN(N, State); +uniform_s(N, {#{bits:=Bits, next:=Next} = Alg, R0}) + when is_integer(N), 1 =< N -> + {V, R1} = Next(R0), + MaxMinusN = ?BIT(Bits) - N, + ?uniform_range(N, Alg, R1, V, MaxMinusN, I); +uniform_s(N, {#{max:=Max, next:=Next} = Alg, R0}) + when is_integer(N), 1 =< N -> + %% Old broken algorithm with skewed probability + %% and gap in ranges > Max + {V, R1} = Next(R0), + if + N =< Max -> + {(V rem N) + 1, {Alg, R1}}; + true -> + F = V / (Max + 1), + {trunc(F * N) + 1, {Alg, R1}} + end. + +%% jump/1: given a state, jump/1 +%% returns a new state which is equivalent to that +%% after a large number of call defined for each algorithm. +%% The large number is algorithm dependent. + +-spec jump(state()) -> NewState :: state(). +jump(State = {#{jump:=Jump}, _}) -> + Jump(State); +jump({#{}, _}) -> + erlang:error(not_implemented). + + +%% jump/0: read the internal state and +%% apply the jump function for the state as in jump/1 +%% and write back the new value to the internal state, +%% then returns the new value. + +-spec jump() -> NewState :: state(). +jump() -> + seed_put(jump(seed_get())). %% normal/0: returns a random float with standard normal distribution %% updating the state in the process dictionary. @@ -159,14 +358,21 @@ normal() -> _ = seed_put(Seed), X. +%% normal/2: returns a random float with N(μ, σ²) normal distribution +%% updating the state in the process dictionary. + +-spec normal(Mean :: number(), Variance :: number()) -> float(). +normal(Mean, Variance) -> + Mean + (math:sqrt(Variance) * normal()). + %% normal_s/1: returns a random float with standard normal distribution %% The Ziggurat Method for generating random variables - Marsaglia and Tsang %% Paper and reference code: http://www.jstatsoft.org/v05/i08/ --spec normal_s(state()) -> {float(), NewS :: state()}. +-spec normal_s(State :: state()) -> {float(), NewState :: state()}. normal_s(State0) -> {Sign, R, State} = get_52(State0), - Idx = R band 16#FF, + Idx = ?MASK(8, R), Idx1 = Idx+1, {Ki, Wi} = normal_kiwi(Idx1), X = R * Wi, @@ -179,22 +385,20 @@ normal_s(State0) -> false -> normal_s(Idx, Sign, -X, State) end. -%% ===================================================================== -%% Internal functions +%% normal_s/3: returns a random float with normal N(μ, σ²) distribution --define(UINT21MASK, 16#00000000001fffff). --define(UINT32MASK, 16#00000000ffffffff). --define(UINT33MASK, 16#00000001ffffffff). --define(UINT39MASK, 16#0000007fffffffff). --define(UINT58MASK, 16#03ffffffffffffff). --define(UINT64MASK, 16#ffffffffffffffff). +-spec normal_s(Mean :: number(), Variance :: number(), state()) -> {float(), NewS :: state()}. +normal_s(Mean, Variance, State0) when Variance > 0 -> + {X, State} = normal_s(State0), + {Mean + (math:sqrt(Variance) * X), State}. --type uint64() :: 0..16#ffffffffffffffff. --type uint58() :: 0..16#03ffffffffffffff. +%% ===================================================================== +%% Internal functions --spec seed_put(state()) -> undefined | state(). +-spec seed_put(state()) -> state(). seed_put(Seed) -> - put(?SEED_DICT, Seed). + put(?SEED_DICT, Seed), + Seed. seed_get() -> case get(?SEED_DICT) of @@ -204,17 +408,30 @@ seed_get() -> %% Setup alg record mk_alg(exs64) -> - {#{type=>exs64, max=>?UINT64MASK, next=>fun exs64_next/1, - uniform=>fun exs64_uniform/1, uniform_n=>fun exs64_uniform/2}, + {#{type=>exs64, max=>?MASK(64), next=>fun exs64_next/1}, fun exs64_seed/1}; mk_alg(exsplus) -> - {#{type=>exsplus, max=>?UINT58MASK, next=>fun exsplus_next/1, - uniform=>fun exsplus_uniform/1, uniform_n=>fun exsplus_uniform/2}, + {#{type=>exsplus, max=>?MASK(58), next=>fun exsplus_next/1, + jump=>fun exsplus_jump/1}, + fun exsplus_seed/1}; +mk_alg(exsp) -> + {#{type=>exsp, bits=>58, weak_low_bits=>1, next=>fun exsplus_next/1, + uniform=>fun exsp_uniform/1, uniform_n=>fun exsp_uniform/2, + jump=>fun exsplus_jump/1}, fun exsplus_seed/1}; mk_alg(exs1024) -> - {#{type=>exs1024, max=>?UINT64MASK, next=>fun exs1024_next/1, - uniform=>fun exs1024_uniform/1, uniform_n=>fun exs1024_uniform/2}, - fun exs1024_seed/1}. + {#{type=>exs1024, max=>?MASK(64), next=>fun exs1024_next/1, + jump=>fun exs1024_jump/1}, + fun exs1024_seed/1}; +mk_alg(exs1024s) -> + {#{type=>exs1024s, bits=>64, weak_low_bits=>3, next=>fun exs1024_next/1, + jump=>fun exs1024_jump/1}, + fun exs1024_seed/1}; +mk_alg(exrop) -> + {#{type=>exrop, bits=>58, weak_low_bits=>1, next=>fun exrop_next/1, + uniform=>fun exrop_uniform/1, uniform_n=>fun exrop_uniform/2, + jump=>fun exrop_jump/1}, + fun exrop_seed/1}. %% ===================================================================== %% exs64 PRNG: Xorshift64* @@ -222,29 +439,21 @@ mk_alg(exs1024) -> %% Reference URL: http://xorshift.di.unimi.it/ %% ===================================================================== --type exs64_state() :: uint64(). +-opaque exs64_state() :: uint64(). exs64_seed({A1, A2, A3}) -> - {V1, _} = exs64_next(((A1 band ?UINT32MASK) * 4294967197 + 1)), - {V2, _} = exs64_next(((A2 band ?UINT32MASK) * 4294967231 + 1)), - {V3, _} = exs64_next(((A3 band ?UINT32MASK) * 4294967279 + 1)), - ((V1 * V2 * V3) rem (?UINT64MASK - 1)) + 1. + {V1, _} = exs64_next((?MASK(32, A1) * 4294967197 + 1)), + {V2, _} = exs64_next((?MASK(32, A2) * 4294967231 + 1)), + {V3, _} = exs64_next((?MASK(32, A3) * 4294967279 + 1)), + ((V1 * V2 * V3) rem (?MASK(64) - 1)) + 1. %% Advance xorshift64* state for one step and generate 64bit unsigned integer -spec exs64_next(exs64_state()) -> {uint64(), exs64_state()}. exs64_next(R) -> R1 = R bxor (R bsr 12), - R2 = R1 bxor ((R1 band ?UINT39MASK) bsl 25), + R2 = R1 bxor ?BSL(64, R1, 25), R3 = R2 bxor (R2 bsr 27), - {(R3 * 2685821657736338717) band ?UINT64MASK, R3}. - -exs64_uniform({Alg, R0}) -> - {V, R1} = exs64_next(R0), - {V / 18446744073709551616, {Alg, R1}}. - -exs64_uniform(Max, {Alg, R}) -> - {V, R1} = exs64_next(R), - {(V rem Max) + 1, {Alg, R1}}. + {?MASK(64, R3 * 2685821657736338717), R3}. %% ===================================================================== %% exsplus PRNG: Xorshift116+ @@ -254,30 +463,75 @@ exs64_uniform(Max, {Alg, R}) -> %% Modification of the original Xorshift128+ algorithm to 116 %% by Sebastiano Vigna, a lot of thanks for his help and work. %% ===================================================================== --type exsplus_state() :: nonempty_improper_list(uint58(), uint58()). +-opaque exsplus_state() :: nonempty_improper_list(uint58(), uint58()). + +-dialyzer({no_improper_lists, exsplus_seed/1}). exsplus_seed({A1, A2, A3}) -> - {_, R1} = exsplus_next([(((A1 * 4294967197) + 1) band ?UINT58MASK)| - (((A2 * 4294967231) + 1) band ?UINT58MASK)]), - {_, R2} = exsplus_next([(((A3 * 4294967279) + 1) band ?UINT58MASK)| - tl(R1)]), + {_, R1} = exsplus_next( + [?MASK(58, (A1 * 4294967197) + 1)| + ?MASK(58, (A2 * 4294967231) + 1)]), + {_, R2} = exsplus_next( + [?MASK(58, (A3 * 4294967279) + 1)| + tl(R1)]), R2. +-dialyzer({no_improper_lists, exsplus_next/1}). + %% Advance xorshift116+ state for one step and generate 58bit unsigned integer -spec exsplus_next(exsplus_state()) -> {uint58(), exsplus_state()}. exsplus_next([S1|S0]) -> %% Note: members s0 and s1 are swapped here - S11 = (S1 bxor (S1 bsl 24)) band ?UINT58MASK, + S11 = S1 bxor ?BSL(58, S1, 24), S12 = S11 bxor S0 bxor (S11 bsr 11) bxor (S0 bsr 41), - {(S0 + S12) band ?UINT58MASK, [S0|S12]}. + {?MASK(58, S0 + S12), [S0|S12]}. + -exsplus_uniform({Alg, R0}) -> +exsp_uniform({Alg, R0}) -> {I, R1} = exsplus_next(R0), - {I / (?UINT58MASK+1), {Alg, R1}}. + %% Waste the lowest bit since it is of lower + %% randomness quality than the others + {(I bsr (58-53)) * ?TWO_POW_MINUS53, {Alg, R1}}. -exsplus_uniform(Max, {Alg, R}) -> +exsp_uniform(Range, {Alg, R}) -> {V, R1} = exsplus_next(R), - {(V rem Max) + 1, {Alg, R1}}. + MaxMinusRange = ?BIT(58) - Range, + ?uniform_range(Range, Alg, R1, V, MaxMinusRange, I). + + +%% This is the jump function for the exsplus generator, equivalent +%% to 2^64 calls to next/1; it can be used to generate 2^52 +%% non-overlapping subsequences for parallel computations. +%% Note: the jump function takes 116 times of the execution time of +%% next/1. + +%% -define(JUMPCONST, 16#000d174a83e17de2302f8ea6bc32c797). +%% split into 58-bit chunks +%% and two iterative executions + +-define(JUMPCONST1, 16#02f8ea6bc32c797). +-define(JUMPCONST2, 16#345d2a0f85f788c). +-define(JUMPELEMLEN, 58). + +-dialyzer({no_improper_lists, exsplus_jump/1}). +-spec exsplus_jump(state()) -> state(). +exsplus_jump({Alg, S}) -> + {S1, AS1} = exsplus_jump(S, [0|0], ?JUMPCONST1, ?JUMPELEMLEN), + {_, AS2} = exsplus_jump(S1, AS1, ?JUMPCONST2, ?JUMPELEMLEN), + {Alg, AS2}. + +-dialyzer({no_improper_lists, exsplus_jump/4}). +exsplus_jump(S, AS, _, 0) -> + {S, AS}; +exsplus_jump(S, [AS0|AS1], J, N) -> + {_, NS} = exsplus_next(S), + case ?MASK(1, J) of + 1 -> + [S0|S1] = S, + exsplus_jump(NS, [(AS0 bxor S0)|(AS1 bxor S1)], J bsr 1, N-1); + 0 -> + exsplus_jump(NS, [AS0|AS1], J bsr 1, N-1) + end. %% ===================================================================== %% exs1024 PRNG: Xorshift1024* @@ -285,12 +539,12 @@ exsplus_uniform(Max, {Alg, R}) -> %% Reference URL: http://xorshift.di.unimi.it/ %% ===================================================================== --type exs1024_state() :: {list(uint64()), list(uint64())}. +-opaque exs1024_state() :: {list(uint64()), list(uint64())}. exs1024_seed({A1, A2, A3}) -> - B1 = (((A1 band ?UINT21MASK) + 1) * 2097131) band ?UINT21MASK, - B2 = (((A2 band ?UINT21MASK) + 1) * 2097133) band ?UINT21MASK, - B3 = (((A3 band ?UINT21MASK) + 1) * 2097143) band ?UINT21MASK, + B1 = ?MASK(21, (?MASK(21, A1) + 1) * 2097131), + B2 = ?MASK(21, (?MASK(21, A2) + 1) * 2097133), + B3 = ?MASK(21, (?MASK(21, A3) + 1) * 2097143), {exs1024_gen1024((B1 bsl 43) bor (B2 bsl 22) bor (B3 bsl 1) bor 1), []}. @@ -313,11 +567,11 @@ exs1024_gen1024(N, R, L) -> %% X: random number output -spec exs1024_calc(uint64(), uint64()) -> {uint64(), uint64()}. exs1024_calc(S0, S1) -> - S11 = S1 bxor ((S1 band ?UINT33MASK) bsl 31), + S11 = S1 bxor ?BSL(64, S1, 31), S12 = S11 bxor (S11 bsr 11), S01 = S0 bxor (S0 bsr 30), NS1 = S01 bxor S12, - {(NS1 * 1181783497276652981) band ?UINT64MASK, NS1}. + {?MASK(64, NS1 * 1181783497276652981), NS1}. %% Advance xorshift1024* state for one step and generate 64bit unsigned integer -spec exs1024_next(exs1024_state()) -> {uint64(), exs1024_state()}. @@ -328,13 +582,190 @@ exs1024_next({[H], RL}) -> NL = [H|lists:reverse(RL)], exs1024_next({NL, []}). -exs1024_uniform({Alg, R0}) -> - {V, R1} = exs1024_next(R0), - {V / 18446744073709551616, {Alg, R1}}. -exs1024_uniform(Max, {Alg, R}) -> - {V, R1} = exs1024_next(R), - {(V rem Max) + 1, {Alg, R1}}. +%% This is the jump function for the exs1024 generator, equivalent +%% to 2^512 calls to next(); it can be used to generate 2^512 +%% non-overlapping subsequences for parallel computations. +%% Note: the jump function takes ~2000 times of the execution time of +%% next/1. + +%% Jump constant here split into 58 bits for speed +-define(JUMPCONSTHEAD, 16#00242f96eca9c41d). +-define(JUMPCONSTTAIL, + [16#0196e1ddbe5a1561, + 16#0239f070b5837a3c, + 16#03f393cc68796cd2, + 16#0248316f404489af, + 16#039a30088bffbac2, + 16#02fea70dc2d9891f, + 16#032ae0d9644caec4, + 16#0313aac17d8efa43, + 16#02f132e055642626, + 16#01ee975283d71c93, + 16#00552321b06f5501, + 16#00c41d10a1e6a569, + 16#019158ecf8aa1e44, + 16#004e9fc949d0b5fc, + 16#0363da172811fdda, + 16#030e38c3b99181f2, + 16#0000000a118038fc]). +-define(JUMPTOTALLEN, 1024). +-define(RINGLEN, 16). + +-spec exs1024_jump(state()) -> state(). + +exs1024_jump({Alg, {L, RL}}) -> + P = length(RL), + AS = exs1024_jump({L, RL}, + [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0], + ?JUMPCONSTTAIL, ?JUMPCONSTHEAD, ?JUMPELEMLEN, ?JUMPTOTALLEN), + {ASL, ASR} = lists:split(?RINGLEN - P, AS), + {Alg, {ASL, lists:reverse(ASR)}}. + +exs1024_jump(_, AS, _, _, _, 0) -> + AS; +exs1024_jump(S, AS, [H|T], _, 0, TN) -> + exs1024_jump(S, AS, T, H, ?JUMPELEMLEN, TN); +exs1024_jump({L, RL}, AS, JL, J, N, TN) -> + {_, NS} = exs1024_next({L, RL}), + case ?MASK(1, J) of + 1 -> + AS2 = lists:zipwith(fun(X, Y) -> X bxor Y end, + AS, L ++ lists:reverse(RL)), + exs1024_jump(NS, AS2, JL, J bsr 1, N-1, TN-1); + 0 -> + exs1024_jump(NS, AS, JL, J bsr 1, N-1, TN-1) + end. + +%% ===================================================================== +%% exrop PRNG: Xoroshiro116+ +%% +%% Reference URL: http://xorshift.di.unimi.it/ +%% +%% 58 bits fits into an immediate on 64bits Erlang and is thus much faster. +%% In fact, an immediate number is 60 bits signed in Erlang so you can +%% add two positive 58 bit numbers and get a 59 bit number that still is +%% a positive immediate, which is a property we utilize here... +%% +%% Modification of the original Xororhiro128+ algorithm to 116 bits +%% by Sebastiano Vigna. A lot of thanks for his help and work. +%% ===================================================================== +%% (a, b, c) = (24, 2, 35) +%% JUMP Polynomial = 0x9863200f83fcd4a11293241fcb12a (116 bit) +%% +%% From http://xoroshiro.di.unimi.it/xoroshiro116plus.c: +%% --------------------------------------------------------------------- +%% /* Written in 2017 by Sebastiano Vigna ([email protected]). +%% +%% To the extent possible under law, the author has dedicated all copyright +%% and related and neighboring rights to this software to the public domain +%% worldwide. This software is distributed without any warranty. +%% +%% See <http://creativecommons.org/publicdomain/zero/1.0/>. */ +%% +%% #include <stdint.h> +%% +%% #define UINT58MASK (uint64_t)((UINT64_C(1) << 58) - 1) +%% +%% uint64_t s[2]; +%% +%% static inline uint64_t rotl58(const uint64_t x, int k) { +%% return (x << k) & UINT58MASK | (x >> (58 - k)); +%% } +%% +%% uint64_t next(void) { +%% uint64_t s1 = s[1]; +%% const uint64_t s0 = s[0]; +%% const uint64_t result = (s0 + s1) & UINT58MASK; +%% +%% s1 ^= s0; +%% s[0] = rotl58(s0, 24) ^ s1 ^ ((s1 << 2) & UINT58MASK); // a, b +%% s[1] = rotl58(s1, 35); // c +%% return result; +%% } +%% +%% void jump(void) { +%% static const uint64_t JUMP[] = +%% { 0x4a11293241fcb12a, 0x0009863200f83fcd }; +%% +%% uint64_t s0 = 0; +%% uint64_t s1 = 0; +%% for(int i = 0; i < sizeof JUMP / sizeof *JUMP; i++) +%% for(int b = 0; b < 64; b++) { +%% if (JUMP[i] & UINT64_C(1) << b) { +%% s0 ^= s[0]; +%% s1 ^= s[1]; +%% } +%% next(); +%% } +%% s[0] = s0; +%% s[1] = s1; +%% } + +-opaque exrop_state() :: nonempty_improper_list(uint58(), uint58()). + +-dialyzer({no_improper_lists, exrop_seed/1}). +exrop_seed({A1, A2, A3}) -> + [_|S1] = + exrop_next_s( + ?MASK(58, (A1 * 4294967197) + 1), + ?MASK(58, (A2 * 4294967231) + 1)), + exrop_next_s(?MASK(58, (A3 * 4294967279) + 1), S1). + +-dialyzer({no_improper_lists, exrop_next_s/2}). +%% Advance xoroshiro116+ state one step +%% [a, b, c] = [24, 2, 35] +-define( + exrop_next_s(S0, S1, S1_a), + begin + S1_a = S1 bxor S0, + [?ROTL(58, S0, 24) bxor S1_a bxor ?BSL(58, S1_a, 2)| % a, b + ?ROTL(58, S1_a, 35)] % c + end). +exrop_next_s(S0, S1) -> + ?exrop_next_s(S0, S1, S1_a). + +-dialyzer({no_improper_lists, exrop_next/1}). +%% Advance xoroshiro116+ state one step, generate 58 bit unsigned integer, +%% and waste the lowest bit since it is of lower randomness quality +exrop_next([S0|S1]) -> + {?MASK(58, S0 + S1), ?exrop_next_s(S0, S1, S1_a)}. + +exrop_uniform({Alg, R}) -> + {V, R1} = exrop_next(R), + %% Waste the lowest bit since it is of lower + %% randomness quality than the others + {(V bsr (58-53)) * ?TWO_POW_MINUS53, {Alg, R1}}. + +exrop_uniform(Range, {Alg, R}) -> + {V, R1} = exrop_next(R), + MaxMinusRange = ?BIT(58) - Range, + ?uniform_range(Range, Alg, R1, V, MaxMinusRange, I). + +%% Split a 116 bit constant into two 58 bit words, +%% a top '1' marks the end of the low word. +-define( + JUMP_116(Jump), + [?BIT(58) bor ?MASK(58, (Jump)),(Jump) bsr 58]). +%% +exrop_jump({Alg,S}) -> + [J|Js] = ?JUMP_116(16#9863200f83fcd4a11293241fcb12a), + {Alg, exrop_jump(S, 0, 0, J, Js)}. +%% +-dialyzer({no_improper_lists, exrop_jump/5}). +exrop_jump(_S, S0, S1, 0, []) -> % End of jump constant + [S0|S1]; +exrop_jump(S, S0, S1, 1, [J|Js]) -> % End of word + exrop_jump(S, S0, S1, J, Js); +exrop_jump([S__0|S__1] = _S, S0, S1, J, Js) -> + case ?MASK(1, J) of + 1 -> + NewS = exrop_next_s(S__0, S__1), + exrop_jump(NewS, S0 bxor S__0, S1 bxor S__1, J bsr 1, Js); + 0 -> + NewS = exrop_next_s(S__0, S__1), + exrop_jump(NewS, S0, S1, J bsr 1, Js) + end. %% ===================================================================== %% Ziggurat cont @@ -343,9 +774,13 @@ exs1024_uniform(Max, {Alg, R}) -> -define(NOR_INV_R, 1/?NOR_R). %% return a {sign, Random51bits, State} +get_52({Alg=#{bits:=Bits, next:=Next}, S0}) -> + %% Use the high bits + {Int,S1} = Next(S0), + {?BIT(Bits - 51 - 1) band Int, Int bsr (Bits - 51), {Alg, S1}}; get_52({Alg=#{next:=Next}, S0}) -> {Int,S1} = Next(S0), - {((1 bsl 51) band Int), Int band ((1 bsl 51)-1), {Alg, S1}}. + {?BIT(51) band Int, ?MASK(51, Int), {Alg, S1}}. %% Slow path normal_s(0, Sign, X0, State0) -> diff --git a/lib/stdlib/src/random.erl b/lib/stdlib/src/random.erl index 8b67cde56c..46dabb4323 100644 --- a/lib/stdlib/src/random.erl +++ b/lib/stdlib/src/random.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2011. All Rights Reserved. +%% Copyright Ericsson AB 1996-2016. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -18,6 +18,7 @@ %% %CopyrightEnd% %% -module(random). +-deprecated(module). %% Reasonable random number generator. %% The method is attributed to B. A. Wichmann and I. D. Hill diff --git a/lib/stdlib/src/re.erl b/lib/stdlib/src/re.erl index e5d9fc51d2..726b409d4d 100644 --- a/lib/stdlib/src/re.erl +++ b/lib/stdlib/src/re.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2008-2014. All Rights Reserved. +%% Copyright Ericsson AB 2008-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -33,7 +33,12 @@ %%% BIFs --export([compile/1, compile/2, run/2, run/3, inspect/2]). +-export([version/0, compile/1, compile/2, run/2, run/3, inspect/2]). + +-spec version() -> binary(). + +version() -> + erlang:nif_error(undef). -spec compile(Regexp) -> {ok, MP} | {error, ErrSpec} when Regexp :: iodata(), @@ -132,8 +137,9 @@ split(Subject,RE) -> split(Subject,RE,Options) -> try - {NewOpt,Convert,Unicode,Limit,Strip,Group} = - process_split_params(Options,iodata,false,-1,false,false), + {NewOpt,Convert,Limit,Strip,Group} = + process_split_params(Options,iodata,-1,false,false), + Unicode = check_for_unicode(RE, Options), FlatSubject = to_binary(Subject, Unicode), case compile_split(RE,NewOpt) of {error,_Err} -> @@ -324,8 +330,8 @@ replace(Subject,RE,Replacement) -> replace(Subject,RE,Replacement,Options) -> try - {NewOpt,Convert,Unicode} = - process_repl_params(Options,iodata,false), + {NewOpt,Convert} = process_repl_params(Options,iodata), + Unicode = check_for_unicode(RE, Options), FlatSubject = to_binary(Subject, Unicode), FlatReplacement = to_binary(Replacement, Unicode), IoList = do_replace(FlatSubject,Subject,RE,FlatReplacement,NewOpt), @@ -367,65 +373,59 @@ do_replace(FlatSubject,Subject,RE,Replacement,Options) -> apply_mlist(FlatSubject,Replacement,[Slist]) end. -process_repl_params([],Convert,Unicode) -> - {[],Convert,Unicode}; -process_repl_params([unicode|T],C,_U) -> - {NT,NC,NU} = process_repl_params(T,C,true), - {[unicode|NT],NC,NU}; -process_repl_params([report_errors|_],_,_) -> +process_repl_params([],Convert) -> + {[],Convert}; +process_repl_params([report_errors|_],_) -> throw(badopt); -process_repl_params([{capture,_,_}|_],_,_) -> +process_repl_params([{capture,_,_}|_],_) -> throw(badopt); -process_repl_params([{capture,_}|_],_,_) -> +process_repl_params([{capture,_}|_],_) -> throw(badopt); -process_repl_params([{return,iodata}|T],_C,U) -> - process_repl_params(T,iodata,U); -process_repl_params([{return,list}|T],_C,U) -> - process_repl_params(T,list,U); -process_repl_params([{return,binary}|T],_C,U) -> - process_repl_params(T,binary,U); -process_repl_params([{return,_}|_],_,_) -> +process_repl_params([{return,iodata}|T],_C) -> + process_repl_params(T,iodata); +process_repl_params([{return,list}|T],_C) -> + process_repl_params(T,list); +process_repl_params([{return,binary}|T],_C) -> + process_repl_params(T,binary); +process_repl_params([{return,_}|_],_) -> throw(badopt); -process_repl_params([H|T],C,U) -> - {NT,NC,NU} = process_repl_params(T,C,U), - {[H|NT],NC,NU}. - -process_split_params([],Convert,Unicode,Limit,Strip,Group) -> - {[],Convert,Unicode,Limit,Strip,Group}; -process_split_params([unicode|T],C,_U,L,S,G) -> - {NT,NC,NU,NL,NS,NG} = process_split_params(T,C,true,L,S,G), - {[unicode|NT],NC,NU,NL,NS,NG}; -process_split_params([trim|T],C,U,_L,_S,G) -> - process_split_params(T,C,U,-1,true,G); -process_split_params([{parts,0}|T],C,U,_L,_S,G) -> - process_split_params(T,C,U,-1,true,G); -process_split_params([{parts,N}|T],C,U,_L,_S,G) when is_integer(N), N >= 1 -> - process_split_params(T,C,U,N-1,false,G); -process_split_params([{parts,infinity}|T],C,U,_L,_S,G) -> - process_split_params(T,C,U,-1,false,G); -process_split_params([{parts,_}|_],_,_,_,_,_) -> +process_repl_params([H|T],C) -> + {NT,NC} = process_repl_params(T,C), + {[H|NT],NC}. + +process_split_params([],Convert,Limit,Strip,Group) -> + {[],Convert,Limit,Strip,Group}; +process_split_params([trim|T],C,_L,_S,G) -> + process_split_params(T,C,-1,true,G); +process_split_params([{parts,0}|T],C,_L,_S,G) -> + process_split_params(T,C,-1,true,G); +process_split_params([{parts,N}|T],C,_L,_S,G) when is_integer(N), N >= 1 -> + process_split_params(T,C,N-1,false,G); +process_split_params([{parts,infinity}|T],C,_L,_S,G) -> + process_split_params(T,C,-1,false,G); +process_split_params([{parts,_}|_],_,_,_,_) -> throw(badopt); -process_split_params([group|T],C,U,L,S,_G) -> - process_split_params(T,C,U,L,S,true); -process_split_params([global|_],_,_,_,_,_) -> +process_split_params([group|T],C,L,S,_G) -> + process_split_params(T,C,L,S,true); +process_split_params([global|_],_,_,_,_) -> throw(badopt); -process_split_params([report_errors|_],_,_,_,_,_) -> +process_split_params([report_errors|_],_,_,_,_) -> throw(badopt); -process_split_params([{capture,_,_}|_],_,_,_,_,_) -> +process_split_params([{capture,_,_}|_],_,_,_,_) -> throw(badopt); -process_split_params([{capture,_}|_],_,_,_,_,_) -> +process_split_params([{capture,_}|_],_,_,_,_) -> throw(badopt); -process_split_params([{return,iodata}|T],_C,U,L,S,G) -> - process_split_params(T,iodata,U,L,S,G); -process_split_params([{return,list}|T],_C,U,L,S,G) -> - process_split_params(T,list,U,L,S,G); -process_split_params([{return,binary}|T],_C,U,L,S,G) -> - process_split_params(T,binary,U,L,S,G); -process_split_params([{return,_}|_],_,_,_,_,_) -> +process_split_params([{return,iodata}|T],_C,L,S,G) -> + process_split_params(T,iodata,L,S,G); +process_split_params([{return,list}|T],_C,L,S,G) -> + process_split_params(T,list,L,S,G); +process_split_params([{return,binary}|T],_C,L,S,G) -> + process_split_params(T,binary,L,S,G); +process_split_params([{return,_}|_],_,_,_,_) -> throw(badopt); -process_split_params([H|T],C,U,L,S,G) -> - {NT,NC,NU,NL,NS,NG} = process_split_params(T,C,U,L,S,G), - {[H|NT],NC,NU,NL,NS,NG}. +process_split_params([H|T],C,L,S,G) -> + {NT,NC,NL,NS,NG} = process_split_params(T,C,L,S,G), + {[H|NT],NC,NL,NS,NG}. apply_mlist(Subject,Replacement,Mlist) -> do_mlist(Subject,Subject,0,precomp_repl(Replacement), Mlist). diff --git a/lib/stdlib/src/sets.erl b/lib/stdlib/src/sets.erl index cd435ff49c..c65a13b22e 100644 --- a/lib/stdlib/src/sets.erl +++ b/lib/stdlib/src/sets.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2000-2014. All Rights Reserved. +%% Copyright Ericsson AB 2000-2016. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -128,14 +128,14 @@ is_element(E, S) -> Set2 :: set(Element). add_element(E, S0) -> Slot = get_slot(S0, E), - {S1,Ic} = on_bucket(fun (B0) -> add_bkt_el(E, B0, B0) end, S0, Slot), - maybe_expand(S1, Ic). - --spec add_bkt_el(T, [T], [T]) -> {[T], 0 | 1}. -add_bkt_el(E, [E|_], Bkt) -> {Bkt,0}; -add_bkt_el(E, [_|B], Bkt) -> - add_bkt_el(E, B, Bkt); -add_bkt_el(E, [], Bkt) -> {[E|Bkt],1}. + Bkt = get_bucket(S0, Slot), + case lists:member(E, Bkt) of + true -> + S0; + false -> + S1 = update_bucket(S0, Slot, [E | Bkt]), + maybe_expand(S1) + end. %% del_element(Element, Set) -> Set. %% Return Set but with Element removed. @@ -144,15 +144,28 @@ add_bkt_el(E, [], Bkt) -> {[E|Bkt],1}. Set2 :: set(Element). del_element(E, S0) -> Slot = get_slot(S0, E), - {S1,Dc} = on_bucket(fun (B0) -> del_bkt_el(E, B0) end, S0, Slot), - maybe_contract(S1, Dc). + Bkt = get_bucket(S0, Slot), + case lists:member(E, Bkt) of + false -> + S0; + true -> + S1 = update_bucket(S0, Slot, lists:delete(E, Bkt)), + maybe_contract(S1, 1) + end. --spec del_bkt_el(T, [T]) -> {[T], 0 | 1}. -del_bkt_el(E, [E|Bkt]) -> {Bkt,1}; -del_bkt_el(E, [Other|Bkt0]) -> - {Bkt1,Dc} = del_bkt_el(E, Bkt0), - {[Other|Bkt1],Dc}; -del_bkt_el(_, []) -> {[],0}. +%% update_bucket(Set, Slot, NewBucket) -> UpdatedSet. +%% Replace bucket in Slot by NewBucket +-spec update_bucket(Set1, Slot, Bkt) -> Set2 when + Set1 :: set(Element), + Set2 :: set(Element), + Slot :: non_neg_integer(), + Bkt :: [Element]. +update_bucket(Set, Slot, NewBucket) -> + SegI = ((Slot-1) div ?seg_size) + 1, + BktI = ((Slot-1) rem ?seg_size) + 1, + Segs = Set#set.segs, + Seg = element(SegI, Segs), + Set#set{segs = setelement(SegI, Segs, setelement(BktI, Seg, NewBucket))}. %% union(Set1, Set2) -> Set %% Return the union of Set1 and Set2. @@ -272,19 +285,6 @@ get_slot(T, Key) -> -spec get_bucket(set(), non_neg_integer()) -> term(). get_bucket(T, Slot) -> get_bucket_s(T#set.segs, Slot). -%% on_bucket(Fun, Hashdb, Slot) -> {NewHashDb,Result}. -%% Apply Fun to the bucket in Slot and replace the returned bucket. --spec on_bucket(fun((_) -> {[_], 0 | 1}), set(E), non_neg_integer()) -> - {set(E), 0 | 1}. -on_bucket(F, T, Slot) -> - SegI = ((Slot-1) div ?seg_size) + 1, - BktI = ((Slot-1) rem ?seg_size) + 1, - Segs = T#set.segs, - Seg = element(SegI, Segs), - B0 = element(BktI, Seg), - {B1, Res} = F(B0), %Op on the bucket. - {T#set{segs = setelement(SegI, Segs, setelement(BktI, Seg, B1))},Res}. - %% fold_set(Fun, Acc, Dictionary) -> Dictionary. %% filter_set(Fun, Dictionary) -> Dictionary. @@ -349,8 +349,8 @@ put_bucket_s(Segs, Slot, Bkt) -> Seg = setelement(BktI, element(SegI, Segs), Bkt), setelement(SegI, Segs, Seg). --spec maybe_expand(set(E), 0 | 1) -> set(E). -maybe_expand(T0, Ic) when T0#set.size + Ic > T0#set.exp_size -> +-spec maybe_expand(set(E)) -> set(E). +maybe_expand(T0) when T0#set.size + 1 > T0#set.exp_size -> T = maybe_expand_segs(T0), %Do we need more segments. N = T#set.n + 1, %Next slot to expand into Segs0 = T#set.segs, @@ -360,12 +360,12 @@ maybe_expand(T0, Ic) when T0#set.size + Ic > T0#set.exp_size -> {B1,B2} = rehash(B, Slot1, Slot2, T#set.maxn), Segs1 = put_bucket_s(Segs0, Slot1, B1), Segs2 = put_bucket_s(Segs1, Slot2, B2), - T#set{size = T#set.size + Ic, + T#set{size = T#set.size + 1, n = N, exp_size = N * ?expand_load, con_size = N * ?contract_load, segs = Segs2}; -maybe_expand(T, Ic) -> T#set{size = T#set.size + Ic}. +maybe_expand(T) -> T#set{size = T#set.size + 1}. -spec maybe_expand_segs(set(E)) -> set(E). maybe_expand_segs(T) when T#set.n =:= T#set.maxn -> diff --git a/lib/stdlib/src/shell.erl b/lib/stdlib/src/shell.erl index c64123a207..ad4984b64c 100644 --- a/lib/stdlib/src/shell.erl +++ b/lib/stdlib/src/shell.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2015. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -23,7 +23,7 @@ -export([whereis_evaluator/0, whereis_evaluator/1]). -export([start_restricted/1, stop_restricted/0]). -export([local_allowed/3, non_local_allowed/3]). --export([prompt_func/1, strings/1]). +-export([catch_exception/1, prompt_func/1, strings/1]). -define(LINEMAX, 30). -define(CHAR_MAX, 60). @@ -229,8 +229,9 @@ server_loop(N0, Eval_0, Bs00, RT, Ds00, History0, Results0) -> {Eval_1,Bs0,Ds0,Prompt} = prompt(N, Eval_0, Bs00, RT, Ds00), {Res,Eval0} = get_command(Prompt, Eval_1, Bs0, RT, Ds0), case Res of - {ok,Es0} -> - case expand_hist(Es0, N) of + {ok,Es0,XBs} -> + Es1 = lib:subst_values_for_vars(Es0, XBs), + case expand_hist(Es1, N) of {ok,Es} -> {V,Eval,Bs,Ds} = shell_cmd(Es, Eval0, Bs0, RT, Ds0, cmd), {History,Results} = check_and_get_history_and_results(), @@ -276,10 +277,10 @@ get_command(Prompt, Eval, Bs, RT, Ds) -> fun() -> exit( case - io:scan_erl_exprs(group_leader(), Prompt, 1) + io:scan_erl_exprs(group_leader(), Prompt, 1, [text]) of {ok,Toks,_EndPos} -> - erl_parse:parse_exprs(Toks); + lib:extended_parse_exprs(Toks); {eof,_EndPos} -> eof; {error,ErrorInfo,_EndPos} -> @@ -700,7 +701,9 @@ exprs([E0|Es], Bs1, RT, Lf, Ef, Bs0, W) -> {W,V0}; true -> case result_will_be_saved() of true -> V0; - false -> ignored + false -> + erlang:garbage_collect(), + ignored end end, {{value,V,Bs,get()},Bs}; @@ -726,7 +729,7 @@ result_will_be_saved() -> used_record_defs(E, RT) -> %% Be careful to return a list where used records come before %% records that use them. The linter wants them ordered that way. - UR = case used_records(E, [], RT) of + UR = case used_records(E, [], RT, []) of [] -> []; L0 -> @@ -736,13 +739,19 @@ used_record_defs(E, RT) -> end, record_defs(RT, UR). -used_records(E, U0, RT) -> +used_records(E, U0, RT, Skip) -> case used_records(E) of {name,Name,E1} -> - U = used_records(ets:lookup(RT, Name), [Name | U0], RT), - used_records(E1, U, RT); + U = case lists:member(Name, Skip) of + true -> + U0; + false -> + R = ets:lookup(RT, Name), + used_records(R, [Name | U0], RT, [Name | Skip]) + end, + used_records(E1, U, RT, Skip); {expr,[E1 | Es]} -> - used_records(Es, used_records(E1, U0, RT), RT); + used_records(Es, used_records(E1, U0, RT, Skip), RT, Skip); _ -> U0 end. @@ -768,6 +777,8 @@ used_records({call,_,{atom,_,record_info},[A,{atom,_,Name}]}) -> {name, Name, A}; used_records({call,Line,{tuple,_,[M,F]},As}) -> used_records({call,Line,{remote,Line,M,F},As}); +used_records({type,_,record,[{atom,_,Name}|Fs]}) -> + {name, Name, Fs}; used_records(T) when is_tuple(T) -> {expr, tuple_to_list(T)}; used_records(E) -> @@ -917,9 +928,9 @@ expand_records(UsedRecords, E0) -> RecordDefs = [Def || {_Name,Def} <- UsedRecords], L = erl_anno:new(1), E = prep_rec(E0), - Forms = RecordDefs ++ [{function,L,foo,0,[{clause,L,[],[],[E]}]}], - [{function,L,foo,0,[{clause,L,[],[],[NE]}]}] = - erl_expand_records:module(Forms, [strict_record_tests]), + Forms0 = RecordDefs ++ [{function,L,foo,0,[{clause,L,[],[],[E]}]}], + Forms = erl_expand_records:module(Forms0, [strict_record_tests]), + {function,L,foo,0,[{clause,L,[],[],[NE]}]} = lists:last(Forms), prep_rec(NE). prep_rec({value,_CommandN,_V}=Value) -> @@ -965,10 +976,11 @@ local_func(f, [{var,_,Name}], Bs, _Shell, _RT, _Lf, _Ef) -> {value,ok,erl_eval:del_binding(Name, Bs)}; local_func(f, [_Other], _Bs, _Shell, _RT, _Lf, _Ef) -> erlang:raise(error, function_clause, [{shell,f,1}]); -local_func(rd, [{atom,_,RecName},RecDef0], Bs, _Shell, RT, _Lf, _Ef) -> +local_func(rd, [{atom,_,RecName0},RecDef0], Bs, _Shell, RT, _Lf, _Ef) -> RecDef = expand_value(RecDef0), RDs = lists:flatten(erl_pp:expr(RecDef)), - Attr = lists:concat(["-record('", RecName, "',", RDs, ")."]), + RecName = io_lib:write_atom_as_latin1(RecName0), + Attr = lists:concat(["-record(", RecName, ",", RDs, ")."]), {ok, Tokens, _} = erl_scan:string(Attr), case erl_parse:parse_form(Tokens) of {ok,AttrForm} -> @@ -999,12 +1011,7 @@ local_func(rl, [A], Bs0, _Shell, RT, Lf, Ef) -> {value,list_records(record_defs(RT, listify(Recs))),Bs}; local_func(rp, [A], Bs0, _Shell, RT, Lf, Ef) -> {[V],Bs} = expr_list([A], Bs0, Lf, Ef), - Cs = io_lib_pretty:print(V, ([{column, 1}, - {line_length, columns()}, - {depth, -1}, - {max_chars, ?CHAR_MAX}, - {record_print_fun, record_print_fun(RT)}] - ++ enc())), + Cs = pp(V, _Column=1, _Depth=-1, RT), io:requests([{put_chars, unicode, Cs}, nl]), {value,ok,Bs}; local_func(rr, [A], Bs0, _Shell, RT, Lf, Ef) -> @@ -1086,6 +1093,8 @@ record_fields([{record_field,_,{atom,_,Field}} | Fs]) -> [Field | record_fields(Fs)]; record_fields([{record_field,_,{atom,_,Field},_} | Fs]) -> [Field | record_fields(Fs)]; +record_fields([{typed_record_field,Field,_Type} | Fs]) -> + record_fields([Field | Fs]); record_fields([]) -> []. @@ -1237,22 +1246,22 @@ read_file_records(File, Opts) -> end. %% This is how the debugger searches for source files. See int.erl. -try_source(Beam, CB) -> - Os = case lists:keyfind(options, 1, binary_to_term(CB)) of - false -> []; - {_, Os0} -> Os0 - end, +try_source(Beam, RawCB) -> + EbinDir = filename:dirname(Beam), + CB = binary_to_term(RawCB), + Os = proplists:get_value(options,CB, []), Src0 = filename:rootname(Beam) ++ ".erl", - case is_file(Src0) of - true -> parse_file(Src0, Os); - false -> - EbinDir = filename:dirname(Beam), - Src = filename:join([filename:dirname(EbinDir), "src", - filename:basename(Src0)]), - case is_file(Src) of - true -> parse_file(Src, Os); - false -> {error, nofile} - end + Src1 = filename:join([filename:dirname(EbinDir), "src", + filename:basename(Src0)]), + Src2 = proplists:get_value(source, CB, []), + try_sources([Src0,Src1,Src2], Os). + +try_sources([], _) -> + {error, nofile}; +try_sources([Src|Rest], Os) -> + case is_file(Src) of + true -> parse_file(Src, Os); + false -> try_sources(Rest, Os) end. is_file(Name) -> @@ -1397,9 +1406,9 @@ get_history_and_results() -> {History, erlang:min(Results, History)}. pp(V, I, RT) -> - pp(V, I, RT, enc()). + pp(V, I, _Depth=?LINEMAX, RT). -pp(V, I, RT, Enc) -> +pp(V, I, D, RT) -> Strings = case application:get_env(stdlib, shell_strings) of {ok, false} -> @@ -1408,19 +1417,21 @@ pp(V, I, RT, Enc) -> true end, io_lib_pretty:print(V, ([{column, I}, {line_length, columns()}, - {depth, ?LINEMAX}, {max_chars, ?CHAR_MAX}, + {depth, D}, {max_chars, ?CHAR_MAX}, {strings, Strings}, {record_print_fun, record_print_fun(RT)}] - ++ Enc)). + ++ enc())). columns() -> case io:columns() of {ok,N} -> N; _ -> 80 end. + encoding() -> [{encoding, Encoding}] = enc(), Encoding. + enc() -> case lists:keyfind(encoding, 1, io:getopts()) of false -> [{encoding,latin1}]; % should never happen @@ -1450,7 +1461,7 @@ check_env(V) -> {ok, Val} -> Txt = io_lib:fwrite ("Invalid value of STDLIB configuration parameter" - "~w: ~tp\n", [V, Val]), + "~tw: ~tp\n", [V, Val]), error_logger:info_report(lists:flatten(Txt)) end. diff --git a/lib/stdlib/src/shell_default.erl b/lib/stdlib/src/shell_default.erl index 4ef5e14db1..a0c1d98513 100644 --- a/lib/stdlib/src/shell_default.erl +++ b/lib/stdlib/src/shell_default.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2010. All Rights Reserved. +%% Copyright Ericsson AB 1996-2016. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -23,7 +23,7 @@ -module(shell_default). --export([help/0,lc/1,c/1,c/2,nc/1,nl/1,l/1,i/0,pid/3,i/3,m/0,m/1, +-export([help/0,lc/1,c/1,c/2,c/3,nc/1,nl/1,l/1,i/0,pid/3,i/3,m/0,m/1,lm/0,mm/0, memory/0,memory/1,uptime/0, erlangrc/1,bi/1, regs/0, flush/0,pwd/0,ls/0,ls/1,cd/1, y/1, y/2, @@ -72,6 +72,7 @@ bi(I) -> c:bi(I). bt(Pid) -> c:bt(Pid). c(File) -> c:c(File). c(File, Opt) -> c:c(File, Opt). +c(File, Opt, Filter) -> c:c(File, Opt, Filter). cd(D) -> c:cd(D). erlangrc(X) -> c:erlangrc(X). flush() -> c:flush(). @@ -83,6 +84,8 @@ ls() -> c:ls(). ls(S) -> c:ls(S). m() -> c:m(). m(Mod) -> c:m(Mod). +lm() -> c:lm(). +mm() -> c:mm(). memory() -> c:memory(). memory(Type) -> c:memory(Type). nc(X) -> c:nc(X). diff --git a/lib/stdlib/src/slave.erl b/lib/stdlib/src/slave.erl index 24fc8ce204..d7cf6386f5 100644 --- a/lib/stdlib/src/slave.erl +++ b/lib/stdlib/src/slave.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2013. All Rights Reserved. +%% Copyright Ericsson AB 1996-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -77,7 +77,7 @@ start_pseudo(_,_,_) -> ok. %% It's already there Pid :: pid(). relay({badrpc,Reason}) -> - error_msg(" ** exiting relay server ~w :~w **~n", [self(),Reason]), + error_msg(" ** exiting relay server ~w :~tw **~n", [self(),Reason]), exit(Reason); relay(undefined) -> error_msg(" ** exiting relay server ~w **~n", [self()]), @@ -289,10 +289,7 @@ register_unique_name(Number) -> %% no need to use rsh. mk_cmd(Host, Name, Args, Waiter, Prog0) -> - Prog = case os:type() of - {ose,_} -> mk_ose_prog(Prog0); - _ -> quote_progname(Prog0) - end, + Prog = quote_progname(Prog0), BasicCmd = lists:concat([Prog, " -detached -noinput -master ", node(), " ", long_or_short(), Name, "@", Host, @@ -312,24 +309,6 @@ mk_cmd(Host, Name, Args, Waiter, Prog0) -> end end. -%% On OSE we have to pass the beam arguments directory to the slave -%% process. To find out what arguments that should be passed on we -%% make an assumption. All arguments after the last "--" should be -%% skipped. So given these arguments: -%% -Muycs256 -A 1 -- -root /mst/ -progname beam.debug.smp -- -home /mst/ -- -kernel inetrc '"/mst/inetrc.conf"' -- -name test@localhost -%% we send -%% -Muycs256 -A 1 -- -root /mst/ -progname beam.debug.smp -- -home /mst/ -- -kernel inetrc '"/mst/inetrc.conf"' -- -%% to the slave with whatever other args that are added in mk_cmd. -mk_ose_prog(Prog) -> - SkipTail = fun("--",[]) -> - ["--"]; - (_,[]) -> - []; - (Arg,Args) -> - [Arg," "|Args] - end, - [Prog,tl(lists:foldr(SkipTail,[],erlang:system_info(emu_args)))]. - %% This is an attempt to distinguish between spaces in the program %% path and spaces that separate arguments. The program is quoted to %% allow spaces in the path. diff --git a/lib/stdlib/src/sofs.erl b/lib/stdlib/src/sofs.erl index bcd1fc11e2..cc50e1b52c 100644 --- a/lib/stdlib/src/sofs.erl +++ b/lib/stdlib/src/sofs.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2001-2014. All Rights Reserved. +%% Copyright Ericsson AB 2001-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -76,7 +76,7 @@ %% %% See also "Naive Set Theory" by Paul R. Halmos. %% -%% By convention, erlang:error/2 is called from exported functions. +%% By convention, erlang:error/1 is called from exported functions. -define(TAG, 'Set'). -define(ORDTAG, 'OrdSet'). @@ -87,12 +87,6 @@ -define(LIST(S), (S)#?TAG.data). -define(TYPE(S), (S)#?TAG.type). -%%-define(SET(L, T), -%% case is_type(T) of -%% true -> #?TAG{data = L, type = T}; -%% false -> erlang:error(badtype, [T]) -%% end -%% ). -define(SET(L, T), #?TAG{data = L, type = T}). -define(IS_SET(S), is_record(S, ?TAG)). -define(IS_UNTYPED_SET(S), ?TYPE(S) =:= ?ANYTYPE). @@ -154,11 +148,8 @@ from_term(T) -> _ when is_list(T) -> [?ANYTYPE]; _ -> ?ANYTYPE end, - case catch setify(T, Type) of - {'EXIT', _} -> - erlang:error(badarg, [T]); - Set -> - Set + try setify(T, Type) + catch _:_ -> erlang:error(badarg) end. -spec(from_term(Term, Type) -> AnySet when @@ -168,14 +159,11 @@ from_term(T) -> from_term(L, T) -> case is_type(T) of true -> - case catch setify(L, T) of - {'EXIT', _} -> - erlang:error(badarg, [L, T]); - Set -> - Set + try setify(L, T) + catch _:_ -> erlang:error(badarg) end; false -> - erlang:error(badarg, [L, T]) + erlang:error(badarg) end. -spec(from_external(ExternalSet, Type) -> AnySet when @@ -208,33 +196,26 @@ is_type(_T) -> Set :: a_set(), Terms :: [term()]). set(L) -> - case catch usort(L) of - {'EXIT', _} -> - erlang:error(badarg, [L]); - SL -> - ?SET(SL, ?ATOM_TYPE) + try usort(L) of + SL -> ?SET(SL, ?ATOM_TYPE) + catch _:_ -> erlang:error(badarg) end. -spec(set(Terms, Type) -> Set when Set :: a_set(), Terms :: [term()], Type :: type()). -set(L, ?SET_OF(Type) = T) when ?IS_ATOM_TYPE(Type), Type =/= ?ANYTYPE -> - case catch usort(L) of - {'EXIT', _} -> - erlang:error(badarg, [L, T]); - SL -> - ?SET(SL, Type) +set(L, ?SET_OF(Type)) when ?IS_ATOM_TYPE(Type), Type =/= ?ANYTYPE -> + try usort(L) of + SL -> ?SET(SL, Type) + catch _:_ -> erlang:error(badarg) end; set(L, ?SET_OF(_) = T) -> - case catch setify(L, T) of - {'EXIT', _} -> - erlang:error(badarg, [L, T]); - Set -> - Set + try setify(L, T) + catch _:_ -> erlang:error(badarg) end; -set(L, T) -> - erlang:error(badarg, [L, T]). +set(_, _) -> + erlang:error(badarg). -spec(from_sets(ListOfSets) -> Set when Set :: a_set(), @@ -245,19 +226,19 @@ set(L, T) -> from_sets(Ss) when is_list(Ss) -> case set_of_sets(Ss, [], ?ANYTYPE) of {error, Error} -> - erlang:error(Error, [Ss]); + erlang:error(Error); Set -> Set end; from_sets(Tuple) when is_tuple(Tuple) -> case ordset_of_sets(tuple_to_list(Tuple), [], []) of error -> - erlang:error(badarg, [Tuple]); + erlang:error(badarg); Set -> Set end; -from_sets(T) -> - erlang:error(badarg, [T]). +from_sets(_) -> + erlang:error(badarg). -spec(relation(Tuples) -> Relation when Relation :: relation(), @@ -265,14 +246,11 @@ from_sets(T) -> relation([]) -> ?SET([], ?BINREL(?ATOM_TYPE, ?ATOM_TYPE)); relation(Ts = [T | _]) when is_tuple(T) -> - case catch rel(Ts, tuple_size(T)) of - {'EXIT', _} -> - erlang:error(badarg, [Ts]); - Set -> - Set + try rel(Ts, tuple_size(T)) + catch _:_ -> erlang:error(badarg) end; -relation(E) -> - erlang:error(badarg, [E]). +relation(_) -> + erlang:error(badarg). -spec(relation(Tuples, Type) -> Relation when N :: integer(), @@ -280,24 +258,20 @@ relation(E) -> Relation :: relation(), Tuples :: [tuple()]). relation(Ts, TS) -> - case catch rel(Ts, TS) of - {'EXIT', _} -> - erlang:error(badarg, [Ts, TS]); - Set -> - Set + try rel(Ts, TS) + catch _:_ -> erlang:error(badarg) end. -spec(a_function(Tuples) -> Function when Function :: a_function(), Tuples :: [tuple()]). a_function(Ts) -> - case catch func(Ts, ?BINREL(?ATOM_TYPE, ?ATOM_TYPE)) of - {'EXIT', _} -> - erlang:error(badarg, [Ts]); + try func(Ts, ?BINREL(?ATOM_TYPE, ?ATOM_TYPE)) of Bad when is_atom(Bad) -> - erlang:error(Bad, [Ts]); - Set -> - Set + erlang:error(Bad); + Set -> + Set + catch _:_ -> erlang:error(badarg) end. -spec(a_function(Tuples, Type) -> Function when @@ -305,26 +279,24 @@ a_function(Ts) -> Tuples :: [tuple()], Type :: type()). a_function(Ts, T) -> - case catch a_func(Ts, T) of - {'EXIT', _} -> - erlang:error(badarg, [Ts, T]); + try a_func(Ts, T) of Bad when is_atom(Bad) -> - erlang:error(Bad, [Ts, T]); + erlang:error(Bad); Set -> Set + catch _:_ -> erlang:error(badarg) end. -spec(family(Tuples) -> Family when Family :: family(), Tuples :: [tuple()]). family(Ts) -> - case catch fam2(Ts, ?FAMILY(?ATOM_TYPE, ?ATOM_TYPE)) of - {'EXIT', _} -> - erlang:error(badarg, [Ts]); + try fam2(Ts, ?FAMILY(?ATOM_TYPE, ?ATOM_TYPE)) of Bad when is_atom(Bad) -> - erlang:error(Bad, [Ts]); + erlang:error(Bad); Set -> Set + catch _:_ -> erlang:error(badarg) end. -spec(family(Tuples, Type) -> Family when @@ -332,13 +304,12 @@ family(Ts) -> Tuples :: [tuple()], Type :: type()). family(Ts, T) -> - case catch fam(Ts, T) of - {'EXIT', _} -> - erlang:error(badarg, [Ts, T]); + try fam(Ts, T) of Bad when is_atom(Bad) -> - erlang:error(Bad, [Ts, T]); + erlang:error(Bad); Set -> Set + catch _:_ -> erlang:error(badarg) end. %%% @@ -373,7 +344,7 @@ to_sets(S) when ?IS_SET(S) -> to_sets(S) when ?IS_ORDSET(S), is_tuple(?ORDTYPE(S)) -> tuple_of_sets(tuple_to_list(?ORDDATA(S)), tuple_to_list(?ORDTYPE(S)), []); to_sets(S) when ?IS_ORDSET(S) -> - erlang:error(badarg, [S]). + erlang:error(badarg). -spec(no_elements(ASet) -> NoElements when ASet :: a_set() | ordset(), @@ -383,7 +354,7 @@ no_elements(S) when ?IS_SET(S) -> no_elements(S) when ?IS_ORDSET(S), is_tuple(?ORDTYPE(S)) -> tuple_size(?ORDDATA(S)); no_elements(S) when ?IS_ORDSET(S) -> - erlang:error(badarg, [S]). + erlang:error(badarg). -spec(specification(Fun, Set1) -> Set2 when Fun :: spec_fun(), @@ -401,7 +372,7 @@ specification(Fun, S) when ?IS_SET(S) -> SL when is_list(SL) -> ?SET(SL, Type); Bad -> - erlang:error(Bad, [Fun, S]) + erlang:error(Bad) end. -spec(union(Set1, Set2) -> Set3 when @@ -410,7 +381,7 @@ specification(Fun, S) when ?IS_SET(S) -> Set3 :: a_set()). union(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> case unify_types(?TYPE(S1), ?TYPE(S2)) of - [] -> erlang:error(type_mismatch, [S1, S2]); + [] -> erlang:error(type_mismatch); Type -> ?SET(umerge(?LIST(S1), ?LIST(S2)), Type) end. @@ -420,7 +391,7 @@ union(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> Set3 :: a_set()). intersection(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> case unify_types(?TYPE(S1), ?TYPE(S2)) of - [] -> erlang:error(type_mismatch, [S1, S2]); + [] -> erlang:error(type_mismatch); Type -> ?SET(intersection(?LIST(S1), ?LIST(S2), []), Type) end. @@ -430,7 +401,7 @@ intersection(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> Set3 :: a_set()). difference(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> case unify_types(?TYPE(S1), ?TYPE(S2)) of - [] -> erlang:error(type_mismatch, [S1, S2]); + [] -> erlang:error(type_mismatch); Type -> ?SET(difference(?LIST(S1), ?LIST(S2), []), Type) end. @@ -440,7 +411,7 @@ difference(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> Set3 :: a_set()). symdiff(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> case unify_types(?TYPE(S1), ?TYPE(S2)) of - [] -> erlang:error(type_mismatch, [S1, S2]); + [] -> erlang:error(type_mismatch); Type -> ?SET(symdiff(?LIST(S1), ?LIST(S2), []), Type) end. @@ -452,7 +423,7 @@ symdiff(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> Set5 :: a_set()). symmetric_partition(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> case unify_types(?TYPE(S1), ?TYPE(S2)) of - [] -> erlang:error(type_mismatch, [S1, S2]); + [] -> erlang:error(type_mismatch); Type -> sympart(?LIST(S1), ?LIST(S2), [], [], [], Type) end. @@ -477,11 +448,9 @@ product({S1, S2}) -> product(S1, S2); product(T) when is_tuple(T) -> Ss = tuple_to_list(T), - case catch sets_to_list(Ss) of - {'EXIT', _} -> - erlang:error(badarg, [T]); + try sets_to_list(Ss) of [] -> - erlang:error(badarg, [T]); + erlang:error(badarg); L -> Type = types(Ss, []), case member([], L) of @@ -490,6 +459,7 @@ product(T) when is_tuple(T) -> false -> ?SET(reverse(prod(L, [], [])), Type) end + catch _:_ -> erlang:error(badarg) end. -spec(constant_function(Set, AnySet) -> Function when @@ -502,10 +472,10 @@ constant_function(S, E) when ?IS_SET(S) -> {Type, true} -> NType = ?BINREL(Type, type(E)), ?SET(constant_function(?LIST(S), to_external(E), []), NType); - _ -> erlang:error(badarg, [S, E]) + _ -> erlang:error(badarg) end; -constant_function(S, E) when ?IS_ORDSET(S) -> - erlang:error(badarg, [S, E]). +constant_function(S, _) when ?IS_ORDSET(S) -> + erlang:error(badarg). -spec(is_equal(AnySet1, AnySet2) -> Bool when AnySet1 :: anyset(), @@ -514,17 +484,17 @@ constant_function(S, E) when ?IS_ORDSET(S) -> is_equal(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> case match_types(?TYPE(S1), ?TYPE(S2)) of true -> ?LIST(S1) == ?LIST(S2); - false -> erlang:error(type_mismatch, [S1, S2]) + false -> erlang:error(type_mismatch) end; is_equal(S1, S2) when ?IS_ORDSET(S1), ?IS_ORDSET(S2) -> case match_types(?ORDTYPE(S1), ?ORDTYPE(S2)) of true -> ?ORDDATA(S1) == ?ORDDATA(S2); - false -> erlang:error(type_mismatch, [S1, S2]) + false -> erlang:error(type_mismatch) end; is_equal(S1, S2) when ?IS_SET(S1), ?IS_ORDSET(S2) -> - erlang:error(type_mismatch, [S1, S2]); + erlang:error(type_mismatch); is_equal(S1, S2) when ?IS_ORDSET(S1), ?IS_SET(S2) -> - erlang:error(type_mismatch, [S1, S2]). + erlang:error(type_mismatch). -spec(is_subset(Set1, Set2) -> Bool when Bool :: boolean(), @@ -533,7 +503,7 @@ is_equal(S1, S2) when ?IS_ORDSET(S1), ?IS_SET(S2) -> is_subset(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> case match_types(?TYPE(S1), ?TYPE(S2)) of true -> subset(?LIST(S1), ?LIST(S2)); - false -> erlang:error(type_mismatch, [S1, S2]) + false -> erlang:error(type_mismatch) end. -spec(is_sofs_set(Term) -> Bool when @@ -573,7 +543,7 @@ is_disjoint(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> [] -> true; [A | As] -> disjoint(?LIST(S2), A, As) end; - false -> erlang:error(type_mismatch, [S1, S2]) + false -> erlang:error(type_mismatch) end. %%% @@ -587,7 +557,7 @@ union(Sets) when ?IS_SET(Sets) -> case ?TYPE(Sets) of ?SET_OF(Type) -> ?SET(lunion(?LIST(Sets)), Type); ?ANYTYPE -> Sets; - _ -> erlang:error(badarg, [Sets]) + _ -> erlang:error(badarg) end. -spec(intersection(SetOfSets) -> Set when @@ -595,12 +565,12 @@ union(Sets) when ?IS_SET(Sets) -> SetOfSets :: set_of_sets()). intersection(Sets) when ?IS_SET(Sets) -> case ?LIST(Sets) of - [] -> erlang:error(badarg, [Sets]); + [] -> erlang:error(badarg); [L | Ls] -> case ?TYPE(Sets) of ?SET_OF(Type) -> ?SET(lintersection(Ls, L), Type); - _ -> erlang:error(badarg, [Sets]) + _ -> erlang:error(badarg) end end. @@ -614,13 +584,16 @@ canonical_relation(Sets) when ?IS_SET(Sets) -> ?SET_OF(Type) -> ?SET(can_rel(?LIST(Sets), []), ?BINREL(Type, ST)); ?ANYTYPE -> Sets; - _ -> erlang:error(badarg, [Sets]) + _ -> erlang:error(badarg) end. %%% %%% Functions on binary relations only. %%% +-spec(rel2fam(BinRel) -> Family when + Family :: family(), + BinRel :: binary_relation()). rel2fam(R) -> relation_to_family(R). @@ -633,7 +606,7 @@ relation_to_family(R) when ?IS_SET(R) -> ?BINREL(DT, RT) -> ?SET(rel2family(?LIST(R)), ?FAMILY(DT, RT)); ?ANYTYPE -> R; - _Else -> erlang:error(badarg, [R]) + _Else -> erlang:error(badarg) end. -spec(domain(BinRel) -> Set when @@ -643,7 +616,7 @@ domain(R) when ?IS_SET(R) -> case ?TYPE(R) of ?BINREL(DT, _) -> ?SET(dom(?LIST(R)), DT); ?ANYTYPE -> R; - _Else -> erlang:error(badarg, [R]) + _Else -> erlang:error(badarg) end. -spec(range(BinRel) -> Set when @@ -653,7 +626,7 @@ range(R) when ?IS_SET(R) -> case ?TYPE(R) of ?BINREL(_, RT) -> ?SET(ran(?LIST(R), []), RT); ?ANYTYPE -> R; - _ -> erlang:error(badarg, [R]) + _ -> erlang:error(badarg) end. -spec(field(BinRel) -> Set when @@ -676,7 +649,7 @@ relative_product(RT) when is_tuple(RT) -> relative_product(RL) when is_list(RL) -> case relprod_n(RL, foo, false, false) of {error, Reason} -> - erlang:error(Reason, [RL]); + erlang:error(Reason); Reply -> Reply end. @@ -700,11 +673,11 @@ relative_product(RL, R) when is_list(RL), ?IS_SET(R) -> EmptyR = case ?TYPE(R) of ?BINREL(_, _) -> ?LIST(R) =:= []; ?ANYTYPE -> true; - _ -> erlang:error(badarg, [RL, R]) + _ -> erlang:error(badarg) end, case relprod_n(RL, R, EmptyR, true) of {error, Reason} -> - erlang:error(Reason, [RL, R]); + erlang:error(Reason); Reply -> Reply end. @@ -717,18 +690,18 @@ relative_product1(R1, R2) when ?IS_SET(R1), ?IS_SET(R2) -> {DTR1, RTR1} = case ?TYPE(R1) of ?BINREL(_, _) = R1T -> R1T; ?ANYTYPE -> {?ANYTYPE, ?ANYTYPE}; - _ -> erlang:error(badarg, [R1, R2]) + _ -> erlang:error(badarg) end, {DTR2, RTR2} = case ?TYPE(R2) of ?BINREL(_, _) = R2T -> R2T; ?ANYTYPE -> {?ANYTYPE, ?ANYTYPE}; - _ -> erlang:error(badarg, [R1, R2]) + _ -> erlang:error(badarg) end, case match_types(DTR1, DTR2) of true when DTR1 =:= ?ANYTYPE -> R1; true when DTR2 =:= ?ANYTYPE -> R2; true -> ?SET(relprod(?LIST(R1), ?LIST(R2)), ?BINREL(RTR1, RTR2)); - false -> erlang:error(type_mismatch, [R1, R2]) + false -> erlang:error(type_mismatch) end. -spec(converse(BinRel1) -> BinRel2 when @@ -738,7 +711,7 @@ converse(R) when ?IS_SET(R) -> case ?TYPE(R) of ?BINREL(DT, RT) -> ?SET(converse(?LIST(R), []), ?BINREL(RT, DT)); ?ANYTYPE -> R; - _ -> erlang:error(badarg, [R]) + _ -> erlang:error(badarg) end. -spec(image(BinRel, Set1) -> Set2 when @@ -752,10 +725,10 @@ image(R, S) when ?IS_SET(R), ?IS_SET(S) -> true -> ?SET(usort(restrict(?LIST(S), ?LIST(R))), RT); false -> - erlang:error(type_mismatch, [R, S]) + erlang:error(type_mismatch) end; ?ANYTYPE -> R; - _ -> erlang:error(badarg, [R, S]) + _ -> erlang:error(badarg) end. -spec(inverse_image(BinRel, Set1) -> Set2 when @@ -770,10 +743,10 @@ inverse_image(R, S) when ?IS_SET(R), ?IS_SET(S) -> NL = restrict(?LIST(S), converse(?LIST(R), [])), ?SET(usort(NL), DT); false -> - erlang:error(type_mismatch, [R, S]) + erlang:error(type_mismatch) end; ?ANYTYPE -> R; - _ -> erlang:error(badarg, [R, S]) + _ -> erlang:error(badarg) end. -spec(strict_relation(BinRel1) -> BinRel2 when @@ -784,7 +757,7 @@ strict_relation(R) when ?IS_SET(R) -> Type = ?BINREL(_, _) -> ?SET(strict(?LIST(R), []), Type); ?ANYTYPE -> R; - _ -> erlang:error(badarg, [R]) + _ -> erlang:error(badarg) end. -spec(weak_relation(BinRel1) -> BinRel2 when @@ -795,12 +768,12 @@ weak_relation(R) when ?IS_SET(R) -> ?BINREL(DT, RT) -> case unify_types(DT, RT) of [] -> - erlang:error(badarg, [R]); + erlang:error(badarg); Type -> ?SET(weak(?LIST(R)), ?BINREL(Type, Type)) end; ?ANYTYPE -> R; - _ -> erlang:error(badarg, [R]) + _ -> erlang:error(badarg) end. -spec(extension(BinRel1, Set, AnySet) -> BinRel2 when @@ -813,7 +786,7 @@ extension(R, S, E) when ?IS_SET(R), ?IS_SET(S) -> {T=?BINREL(DT, RT), ST, true} -> case match_types(DT, ST) and match_types(RT, type(E)) of false -> - erlang:error(type_mismatch, [R, S, E]); + erlang:error(type_mismatch); true -> RL = ?LIST(R), case extc([], ?LIST(S), to_external(E), RL) of @@ -833,7 +806,7 @@ extension(R, S, E) when ?IS_SET(R), ?IS_SET(S) -> ?SET([], ?BINREL(ST, ET)) end; {_, _, true} -> - erlang:error(badarg, [R, S, E]) + erlang:error(badarg) end. -spec(is_a_function(BinRel) -> Bool when @@ -847,7 +820,7 @@ is_a_function(R) when ?IS_SET(R) -> [{V,_} | Es] -> is_a_func(Es, V) end; ?ANYTYPE -> true; - _ -> erlang:error(badarg, [R]) + _ -> erlang:error(badarg) end. -spec(restriction(BinRel1, Set) -> BinRel2 when @@ -876,12 +849,12 @@ composite(Fn1, Fn2) when ?IS_SET(Fn1), ?IS_SET(Fn2) -> ?BINREL(DTF1, RTF1) = case ?TYPE(Fn1)of ?BINREL(_, _) = F1T -> F1T; ?ANYTYPE -> {?ANYTYPE, ?ANYTYPE}; - _ -> erlang:error(badarg, [Fn1, Fn2]) + _ -> erlang:error(badarg) end, ?BINREL(DTF2, RTF2) = case ?TYPE(Fn2) of ?BINREL(_, _) = F2T -> F2T; ?ANYTYPE -> {?ANYTYPE, ?ANYTYPE}; - _ -> erlang:error(badarg, [Fn1, Fn2]) + _ -> erlang:error(badarg) end, case match_types(RTF1, DTF2) of true when DTF1 =:= ?ANYTYPE -> Fn1; @@ -891,9 +864,9 @@ composite(Fn1, Fn2) when ?IS_SET(Fn1), ?IS_SET(Fn2) -> SL when is_list(SL) -> ?SET(sort(SL), ?BINREL(DTF1, RTF2)); Bad -> - erlang:error(Bad, [Fn1, Fn2]) + erlang:error(Bad) end; - false -> erlang:error(type_mismatch, [Fn1, Fn2]) + false -> erlang:error(type_mismatch) end. -spec(inverse(Function1) -> Function2 when @@ -906,10 +879,10 @@ inverse(Fn) when ?IS_SET(Fn) -> SL when is_list(SL) -> ?SET(SL, ?BINREL(RT, DT)); Bad -> - erlang:error(Bad, [Fn]) + erlang:error(Bad) end; ?ANYTYPE -> Fn; - _ -> erlang:error(badarg, [Fn]) + _ -> erlang:error(badarg) end. %%% @@ -929,7 +902,7 @@ restriction(I, R, S) when is_integer(I), ?IS_SET(R), ?IS_SET(S) -> empty -> R; error -> - erlang:error(badarg, [I, R, S]); + erlang:error(badarg); Sort -> RL = ?LIST(R), case {match_types(?REL_TYPE(I, RT), ST), ?LIST(S)} of @@ -942,7 +915,7 @@ restriction(I, R, S) when is_integer(I), ?IS_SET(R), ?IS_SET(S) -> {true, [E | Es]} -> ?SET(sort(restrict_n(I, keysort(I, RL), E, Es, [])), RT); {false, _SL} -> - erlang:error(type_mismatch, [I, R, S]) + erlang:error(type_mismatch) end end; restriction(SetFun, S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> @@ -960,28 +933,27 @@ restriction(SetFun, S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> NL = sort(restrict(?LIST(S2), converse(NSL, []))), ?SET(NL, Type1); false -> - erlang:error(type_mismatch, [SetFun, S1, S2]) + erlang:error(type_mismatch) end; Bad -> - erlang:error(Bad, [SetFun, S1, S2]) + erlang:error(Bad) end; _ when Type1 =:= ?ANYTYPE -> S1; _XFun when ?IS_SET_OF(Type1) -> - erlang:error(badarg, [SetFun, S1, S2]); + erlang:error(badarg); XFun -> FunT = XFun(Type1), - case catch check_fun(Type1, XFun, FunT) of - {'EXIT', _} -> - erlang:error(badarg, [SetFun, S1, S2]); + try check_fun(Type1, XFun, FunT) of Sort -> case match_types(FunT, Type2) of true -> R1 = inverse_substitution(SL1, XFun, Sort), ?SET(sort(Sort, restrict(?LIST(S2), R1)), Type1); false -> - erlang:error(type_mismatch, [SetFun, S1, S2]) + erlang:error(type_mismatch) end + catch _:_ -> erlang:error(badarg) end end. @@ -997,7 +969,7 @@ drestriction(I, R, S) when is_integer(I), ?IS_SET(R), ?IS_SET(S) -> empty -> R; error -> - erlang:error(badarg, [I, R, S]); + erlang:error(badarg); Sort -> RL = ?LIST(R), case {match_types(?REL_TYPE(I, RT), ST), ?LIST(S)} of @@ -1010,7 +982,7 @@ drestriction(I, R, S) when is_integer(I), ?IS_SET(R), ?IS_SET(S) -> {true, [E | Es]} -> ?SET(diff_restrict_n(I, keysort(I, RL), E, Es, []), RT); {false, _SL} -> - erlang:error(type_mismatch, [I, R, S]) + erlang:error(type_mismatch) end end; drestriction(SetFun, S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> @@ -1029,20 +1001,18 @@ drestriction(SetFun, S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> NL = sort(diff_restrict(SL2, converse(NSL, []))), ?SET(NL, Type1); false -> - erlang:error(type_mismatch, [SetFun, S1, S2]) + erlang:error(type_mismatch) end; Bad -> - erlang:error(Bad, [SetFun, S1, S2]) + erlang:error(Bad) end; _ when Type1 =:= ?ANYTYPE -> S1; _XFun when ?IS_SET_OF(Type1) -> - erlang:error(badarg, [SetFun, S1, S2]); + erlang:error(badarg); XFun -> FunT = XFun(Type1), - case catch check_fun(Type1, XFun, FunT) of - {'EXIT', _} -> - erlang:error(badarg, [SetFun, S1, S2]); + try check_fun(Type1, XFun, FunT) of Sort -> case match_types(FunT, Type2) of true -> @@ -1050,8 +1020,9 @@ drestriction(SetFun, S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> SL2 = ?LIST(S2), ?SET(sort(Sort, diff_restrict(SL2, R1)), Type1); false -> - erlang:error(type_mismatch, [SetFun, S1, S2]) + erlang:error(type_mismatch) end + catch _:_ -> erlang:error(badarg) end end. @@ -1065,7 +1036,7 @@ projection(I, Set) when is_integer(I), ?IS_SET(Set) -> empty -> Set; error -> - erlang:error(badarg, [I, Set]); + erlang:error(badarg); _ when I =:= 1 -> ?SET(projection1(?LIST(Set)), ?REL_TYPE(I, Type)); _ -> @@ -1084,7 +1055,7 @@ substitution(I, Set) when is_integer(I), ?IS_SET(Set) -> empty -> Set; error -> - erlang:error(badarg, [I, Set]); + erlang:error(badarg); _Sort -> NType = ?REL_TYPE(I, Type), NSL = substitute_element(?LIST(Set), I, []), @@ -1099,22 +1070,21 @@ substitution(SetFun, Set) when ?IS_SET(Set) -> {SL, NewType} -> ?SET(reverse(SL), ?BINREL(Type, NewType)); Bad -> - erlang:error(Bad, [SetFun, Set]) + erlang:error(Bad) end; false -> empty_set(); _ when Type =:= ?ANYTYPE -> empty_set(); _XFun when ?IS_SET_OF(Type) -> - erlang:error(badarg, [SetFun, Set]); + erlang:error(badarg); XFun -> FunT = XFun(Type), - case catch check_fun(Type, XFun, FunT) of - {'EXIT', _} -> - erlang:error(badarg, [SetFun, Set]); + try check_fun(Type, XFun, FunT) of _Sort -> SL = substitute(L, XFun, []), ?SET(SL, ?BINREL(Type, FunT)) + catch _:_ -> erlang:error(badarg) end end. @@ -1136,7 +1106,7 @@ partition(I, Set) when is_integer(I), ?IS_SET(Set) -> empty -> Set; error -> - erlang:error(badarg, [I, Set]); + erlang:error(badarg); false -> % I =:= 1 ?SET(partition_n(I, ?LIST(Set)), ?SET_OF(Type)); true -> @@ -1158,7 +1128,7 @@ partition(I, R, S) when is_integer(I), ?IS_SET(R), ?IS_SET(S) -> empty -> {R, R}; error -> - erlang:error(badarg, [I, R, S]); + erlang:error(badarg); Sort -> RL = ?LIST(R), case {match_types(?REL_TYPE(I, RT), ST), ?LIST(S)} of @@ -1173,7 +1143,7 @@ partition(I, R, S) when is_integer(I), ?IS_SET(R), ?IS_SET(S) -> [L1 | L2] = partition3_n(I, keysort(I,RL), E, Es, [], []), {?SET(L1, RT), ?SET(L2, RT)}; {false, _SL} -> - erlang:error(type_mismatch, [I, R, S]) + erlang:error(type_mismatch) end end; partition(SetFun, S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> @@ -1192,20 +1162,18 @@ partition(SetFun, S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> [L1 | L2] = partition3(?LIST(S2), R1), {?SET(sort(L1), Type1), ?SET(sort(L2), Type1)}; false -> - erlang:error(type_mismatch, [SetFun, S1, S2]) + erlang:error(type_mismatch) end; Bad -> - erlang:error(Bad, [SetFun, S1, S2]) + erlang:error(Bad) end; _ when Type1 =:= ?ANYTYPE -> {S1, S1}; _XFun when ?IS_SET_OF(Type1) -> - erlang:error(badarg, [SetFun, S1, S2]); + erlang:error(badarg); XFun -> FunT = XFun(Type1), - case catch check_fun(Type1, XFun, FunT) of - {'EXIT', _} -> - erlang:error(badarg, [SetFun, S1, S2]); + try check_fun(Type1, XFun, FunT) of Sort -> case match_types(FunT, Type2) of true -> @@ -1213,8 +1181,9 @@ partition(SetFun, S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> [L1 | L2] = partition3(?LIST(S2), R1), {?SET(sort(L1), Type1), ?SET(sort(L2), Type1)}; false -> - erlang:error(type_mismatch, [SetFun, S1, S2]) + erlang:error(type_mismatch) end + catch _:_ -> erlang:error(badarg) end end. @@ -1231,7 +1200,7 @@ multiple_relative_product(T, R) when is_tuple(T), ?IS_SET(R) -> MProd = mul_relprod(tuple_to_list(T), 1, R), relative_product(MProd); false -> - erlang:error(badarg, [T, R]) + erlang:error(badarg) end. -spec(join(Relation1, I, Relation2, J) -> Relation3 when @@ -1243,8 +1212,7 @@ multiple_relative_product(T, R) when is_tuple(T), ?IS_SET(R) -> join(R1, I1, R2, I2) when ?IS_SET(R1), ?IS_SET(R2), is_integer(I1), is_integer(I2) -> case test_rel(R1, I1, lte) and test_rel(R2, I2, lte) of - false -> - erlang:error(badarg, [R1, I1, R2, I2]); + false -> erlang:error(badarg); true when ?TYPE(R1) =:= ?ANYTYPE -> R1; true when ?TYPE(R2) =:= ?ANYTYPE -> R2; true -> @@ -1291,7 +1259,7 @@ family_to_relation(F) when ?IS_SET(F) -> ?FAMILY(DT, RT) -> ?SET(family2rel(?LIST(F), []), ?BINREL(DT, RT)); ?ANYTYPE -> F; - _ -> erlang:error(badarg, [F]) + _ -> erlang:error(badarg) end. -spec(family_specification(Fun, Family1) -> Family2 when @@ -1311,10 +1279,10 @@ family_specification(Fun, F) when ?IS_SET(F) -> SL when is_list(SL) -> ?SET(SL, FType); Bad -> - erlang:error(Bad, [Fun, F]) + erlang:error(Bad) end; ?ANYTYPE -> F; - _ -> erlang:error(badarg, [Fun, F]) + _ -> erlang:error(badarg) end. -spec(union_of_family(Family) -> Set when @@ -1325,7 +1293,7 @@ union_of_family(F) when ?IS_SET(F) -> ?FAMILY(_DT, Type) -> ?SET(un_of_fam(?LIST(F), []), Type); ?ANYTYPE -> F; - _ -> erlang:error(badarg, [F]) + _ -> erlang:error(badarg) end. -spec(intersection_of_family(Family) -> Set when @@ -1338,9 +1306,9 @@ intersection_of_family(F) when ?IS_SET(F) -> FU when is_list(FU) -> ?SET(FU, Type); Bad -> - erlang:error(Bad, [F]) + erlang:error(Bad) end; - _ -> erlang:error(badarg, [F]) + _ -> erlang:error(badarg) end. -spec(family_union(Family1) -> Family2 when @@ -1351,7 +1319,7 @@ family_union(F) when ?IS_SET(F) -> ?FAMILY(DT, ?SET_OF(Type)) -> ?SET(fam_un(?LIST(F), []), ?FAMILY(DT, Type)); ?ANYTYPE -> F; - _ -> erlang:error(badarg, [F]) + _ -> erlang:error(badarg) end. -spec(family_intersection(Family1) -> Family2 when @@ -1364,10 +1332,10 @@ family_intersection(F) when ?IS_SET(F) -> FU when is_list(FU) -> ?SET(FU, ?FAMILY(DT, Type)); Bad -> - erlang:error(Bad, [F]) + erlang:error(Bad) end; ?ANYTYPE -> F; - _ -> erlang:error(badarg, [F]) + _ -> erlang:error(badarg) end. -spec(family_domain(Family1) -> Family2 when @@ -1379,7 +1347,7 @@ family_domain(F) when ?IS_SET(F) -> ?SET(fam_dom(?LIST(F), []), ?FAMILY(FDT, DT)); ?ANYTYPE -> F; ?FAMILY(_, ?ANYTYPE) -> F; - _ -> erlang:error(badarg, [F]) + _ -> erlang:error(badarg) end. -spec(family_range(Family1) -> Family2 when @@ -1391,7 +1359,7 @@ family_range(F) when ?IS_SET(F) -> ?SET(fam_ran(?LIST(F), []), ?FAMILY(DT, RT)); ?ANYTYPE -> F; ?FAMILY(_, ?ANYTYPE) -> F; - _ -> erlang:error(badarg, [F]) + _ -> erlang:error(badarg) end. -spec(family_field(Family1) -> Family2 when @@ -1425,12 +1393,12 @@ family_difference(F1, F2) -> fam_binop(F1, F2, FF) when ?IS_SET(F1), ?IS_SET(F2) -> case unify_types(?TYPE(F1), ?TYPE(F2)) of [] -> - erlang:error(type_mismatch, [F1, F2]); + erlang:error(type_mismatch); ?ANYTYPE -> F1; Type = ?FAMILY(_, _) -> ?SET(FF(?LIST(F1), ?LIST(F2), []), Type); - _ -> erlang:error(badarg, [F1, F2]) + _ -> erlang:error(badarg) end. -spec(partition_family(SetFun, Set) -> Family when @@ -1443,7 +1411,7 @@ partition_family(I, Set) when is_integer(I), ?IS_SET(Set) -> empty -> Set; error -> - erlang:error(badarg, [I, Set]); + erlang:error(badarg); false -> % when I =:= 1 ?SET(fam_partition_n(I, ?LIST(Set)), ?BINREL(?REL_TYPE(I, Type), ?SET_OF(Type))); @@ -1461,23 +1429,22 @@ partition_family(SetFun, Set) when ?IS_SET(Set) -> P = fam_partition(converse(NSL, []), true), ?SET(reverse(P), ?BINREL(NewType, ?SET_OF(Type))); Bad -> - erlang:error(Bad, [SetFun, Set]) + erlang:error(Bad) end; false -> empty_set(); _ when Type =:= ?ANYTYPE -> empty_set(); _XFun when ?IS_SET_OF(Type) -> - erlang:error(badarg, [SetFun, Set]); + erlang:error(badarg); XFun -> DType = XFun(Type), - case catch check_fun(Type, XFun, DType) of - {'EXIT', _} -> - erlang:error(badarg, [SetFun, Set]); + try check_fun(Type, XFun, DType) of Sort -> Ts = inverse_substitution(?LIST(Set), XFun, Sort), P = fam_partition(Ts, Sort), ?SET(reverse(P), ?BINREL(DType, ?SET_OF(Type))) + catch _:_ -> erlang:error(badarg) end end. @@ -1496,13 +1463,13 @@ family_projection(SetFun, F) when ?IS_SET(F) -> {SL, NewType} -> ?SET(SL, ?BINREL(DT, NewType)); Bad -> - erlang:error(Bad, [SetFun, F]) + erlang:error(Bad) end; _ -> - erlang:error(badarg, [SetFun, F]) + erlang:error(badarg) end; ?ANYTYPE -> F; - _ -> erlang:error(badarg, [SetFun, F]) + _ -> erlang:error(badarg) end. %%% @@ -1516,7 +1483,7 @@ family_to_digraph(F) when ?IS_SET(F) -> case ?TYPE(F) of ?FAMILY(_, _) -> fam2digraph(F, digraph:new()); ?ANYTYPE -> digraph:new(); - _Else -> erlang:error(badarg, [F]) + _Else -> erlang:error(badarg) end. -spec(family_to_digraph(Family, GraphType) -> Graph when @@ -1527,27 +1494,27 @@ family_to_digraph(F, Type) when ?IS_SET(F) -> case ?TYPE(F) of ?FAMILY(_, _) -> ok; ?ANYTYPE -> ok; - _Else -> erlang:error(badarg, [F, Type]) + _Else -> erlang:error(badarg) end, try digraph:new(Type) of G -> case catch fam2digraph(F, G) of {error, Reason} -> true = digraph:delete(G), - erlang:error(Reason, [F, Type]); + erlang:error(Reason); _ -> G end catch - error:badarg -> erlang:error(badarg, [F, Type]) + error:badarg -> erlang:error(badarg) end. -spec(digraph_to_family(Graph) -> Family when Graph :: digraph:graph(), Family :: family()). digraph_to_family(G) -> - case catch digraph_family(G) of - {'EXIT', _} -> erlang:error(badarg, [G]); + try digraph_family(G) of L -> ?SET(L, ?FAMILY(?ATOM_TYPE, ?ATOM_TYPE)) + catch _:_ -> erlang:error(badarg) end. -spec(digraph_to_family(Graph, Type) -> Family when @@ -1557,12 +1524,12 @@ digraph_to_family(G) -> digraph_to_family(G, T) -> case {is_type(T), T} of {true, ?SET_OF(?FAMILY(_,_) = Type)} -> - case catch digraph_family(G) of - {'EXIT', _} -> erlang:error(badarg, [G, T]); + try digraph_family(G) of L -> ?SET(L, Type) + catch _:_ -> erlang:error(badarg) end; _ -> - erlang:error(badarg, [G, T]) + erlang:error(badarg) end. %% @@ -1710,14 +1677,15 @@ func_type([], SL, Type, F) -> setify(L, ?SET_OF(Atom)) when ?IS_ATOM_TYPE(Atom), Atom =/= ?ANYTYPE -> ?SET(usort(L), Atom); setify(L, ?SET_OF(Type0)) -> - case catch is_no_lists(Type0) of - {'EXIT', _} -> - {?SET_OF(Type), Set} = create(L, Type0, Type0, []), - ?SET(Set, Type); + try is_no_lists(Type0) of N when is_integer(N) -> - rel(L, N, Type0); + rel(L, N, Type0); Sizes -> make_oset(L, Sizes, L, Type0) + catch + _:_ -> + {?SET_OF(Type), Set} = create(L, Type0, Type0, []), + ?SET(Set, Type) end; setify(E, Type0) -> {Type, OrdSet} = make_element(E, Type0, Type0), diff --git a/lib/stdlib/src/stdlib.app.src b/lib/stdlib/src/stdlib.app.src index 4400956943..3c449d3cb9 100644 --- a/lib/stdlib/src/stdlib.app.src +++ b/lib/stdlib/src/stdlib.app.src @@ -2,7 +2,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2015. All Rights Reserved. +%% Copyright Ericsson AB 1996-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -31,7 +31,6 @@ dets_server, dets_sup, dets_utils, - dets_v8, dets_v9, dict, digraph, @@ -40,6 +39,7 @@ edlin_expand, epp, eval_bits, + erl_abstract_code, erl_anno, erl_bits, erl_compile, @@ -65,6 +65,7 @@ gen_event, gen_fsm, gen_server, + gen_statem, io, io_lib, io_lib_format, @@ -99,13 +100,14 @@ sys, timer, unicode, + unicode_util, win32reg, zip]}, {registered,[timer_server,rsh_starter,take_over_monitor,pool_master, dets]}, {applications, [kernel]}, {env, []}, - {runtime_dependencies, ["sasl-2.4","kernel-4.0","erts-7.0","crypto-3.3", + {runtime_dependencies, ["sasl-3.0","kernel-5.0","erts-9.0","crypto-3.3", "compiler-5.0"]} ]}. diff --git a/lib/stdlib/src/stdlib.appup.src b/lib/stdlib/src/stdlib.appup.src index 828e1d9aa4..800c2c61f3 100644 --- a/lib/stdlib/src/stdlib.appup.src +++ b/lib/stdlib/src/stdlib.appup.src @@ -1,7 +1,7 @@ %% -*- erlang -*- %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1999-2015. All Rights Reserved. +%% Copyright Ericsson AB 1999-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -18,7 +18,9 @@ %% %CopyrightEnd% {"%VSN%", %% Up from - max one major revision back - [{<<"2\\.[0-4](\\.[0-9]+)*">>,[restart_new_emulator]}], %% 17.0-17.5 + [{<<"3\\.[0-3](\\.[0-9]+)*">>,[restart_new_emulator]}, % OTP-19.* + {<<"3\\.4(\\.[0-9]+)*">>,[restart_new_emulator]}], % OTP-20.* %% Down to - max one major revision back - [{<<"2\\.[0-4](\\.[0-9]+)*">>,[restart_new_emulator]}] %% 17.0-17.5 + [{<<"3\\.[0-3](\\.[0-9]+)*">>,[restart_new_emulator]}, % OTP-19.* + {<<"3\\.4(\\.[0-9]+)*">>,[restart_new_emulator]}] % OTP-20.* }. diff --git a/lib/stdlib/src/string.erl b/lib/stdlib/src/string.erl index 07659ed812..6f5e617230 100644 --- a/lib/stdlib/src/string.erl +++ b/lib/stdlib/src/string.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2013. All Rights Reserved. +%% Copyright Ericsson AB 1996-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -17,43 +17,1612 @@ %% %% %CopyrightEnd% %% +%% A string library that works on grapheme clusters, with the exception +%% of codepoints of class 'prepend' and non modern (or decomposed) Hangul. +%% If these codepoints appear, functions like 'find/2' may return a string +%% which starts inside a grapheme cluster. +%% These exceptions are made because the codepoints classes are +%% seldom used and require that we are able look at previous codepoints in +%% the stream and is thus hard to implement effectively. +%% +%% GC (grapheme cluster) implies that the length of string 'ß↑e̊' is 3 though +%% it is represented by the codepoints [223,8593,101,778] or the +%% utf8 binary <<195,159,226,134,145,101,204,138>> +%% +%% And that searching for strings or graphemes finds the correct positions: +%% +%% find("eeeee̊eee", "e̊") -> "e̊ee".: +%% find("1£4e̊abcdef", "e") -> "ef" +%% +%% Most functions expect all input to be normalized to one form, +%% see unicode:characters_to_nfc and unicode:characters_to_nfd functions. +%% When appending strings no checking is done to verify that the +%% result is valid unicode strings. +%% +%% The functions may crash for invalid utf-8 input. +%% +%% Return value should be kept consistent when return type is +%% unicode:chardata() i.e. binary input => binary output, +%% list input => list output mixed input => mixed output +%% -module(string). --export([len/1,equal/2,concat/2,chr/2,rchr/2,str/2,rstr/2, - span/2,cspan/2,substr/2,substr/3,tokens/2,chars/2,chars/3]). +-export([is_empty/1, length/1, to_graphemes/1, + reverse/1, + equal/2, equal/3, equal/4, + slice/2, slice/3, + pad/2, pad/3, pad/4, trim/1, trim/2, trim/3, chomp/1, + take/2, take/3, take/4, + lexemes/2, nth_lexeme/3, + uppercase/1, lowercase/1, titlecase/1,casefold/1, + prefix/2, + split/2,split/3,replace/3,replace/4, + find/2,find/3, + next_codepoint/1, next_grapheme/1 + ]). + +-export([to_float/1, to_integer/1]). + +%% Old (will be deprecated) lists/string API kept for backwards compability +-export([len/1, concat/2, % equal/2, (extended in the new api) + chr/2,rchr/2,str/2,rstr/2, + span/2,cspan/2,substr/2,substr/3, tokens/2, + chars/2,chars/3]). -export([copies/2,words/1,words/2,strip/1,strip/2,strip/3, sub_word/2,sub_word/3,left/2,left/3,right/2,right/3, sub_string/2,sub_string/3,centre/2,centre/3, join/2]). -export([to_upper/1, to_lower/1]). +%% +-import(lists,[member/2]). +-compile({no_auto_import,[length/1]}). +-compile({inline, [btoken/2, rev/1, append/2, stack/2, search_compile/1]}). +-define(ASCII_LIST(CP1,CP2), CP1 < 256, CP2 < 256, CP1 =/= $\r). --import(lists,[reverse/1,member/2]). +-export_type([grapheme_cluster/0]). -%%--------------------------------------------------------------------------- +-type grapheme_cluster() :: char() | [char()]. +-type direction() :: 'leading' | 'trailing'. -%%% BIFs +-dialyzer({no_improper_lists, [stack/2, length_b/3]}). +%%% BIFs internal (not documented) should not to be used outside of this module +%%% May be removed +-export([list_to_float/1, list_to_integer/1]). --export([to_float/1, to_integer/1]). --spec to_float(String) -> {Float, Rest} | {error, Reason} when +%% Uses bifs: string:list_to_float/1 and string:list_to_integer/1 +-spec list_to_float(String) -> {Float, Rest} | {'error', Reason} when String :: string(), Float :: float(), Rest :: string(), - Reason :: no_float | not_a_list. + Reason :: 'no_float' | 'not_a_list'. -to_float(_) -> +list_to_float(_) -> erlang:nif_error(undef). --spec to_integer(String) -> {Int, Rest} | {error, Reason} when +-spec list_to_integer(String) -> {Int, Rest} | {'error', Reason} when String :: string(), Int :: integer(), Rest :: string(), - Reason :: no_integer | not_a_list. + Reason :: 'no_integer' | 'not_a_list'. -to_integer(_) -> +list_to_integer(_) -> erlang:nif_error(undef). %%% End of BIFs +%% Check if string is the empty string +-spec is_empty(String::unicode:chardata()) -> boolean(). +is_empty([]) -> true; +is_empty(<<>>) -> true; +is_empty([L|R]) -> is_empty(L) andalso is_empty(R); +is_empty(_) -> false. + +%% Count the number of grapheme clusters in chardata +-spec length(String::unicode:chardata()) -> non_neg_integer(). +length(<<CP1/utf8, Bin/binary>>) -> + length_b(Bin, CP1, 0); +length(CD) -> + length_1(CD, 0). + +%% Convert a string to a list of grapheme clusters +-spec to_graphemes(String::unicode:chardata()) -> [grapheme_cluster()]. +to_graphemes(CD0) -> + case unicode_util:gc(CD0) of + [GC|CD] -> [GC|to_graphemes(CD)]; + [] -> [] + end. + +%% Compare two strings return boolean, assumes that the input are +%% normalized to same form, see unicode:characters_to_nfX_xxx(..) +-spec equal(A, B) -> boolean() when + A::unicode:chardata(), + B::unicode:chardata(). +equal(A,B) when is_binary(A), is_binary(B) -> + A =:= B; +equal(A,B) -> + equal_1(A,B). + +%% Compare two strings return boolean, assumes that the input are +%% normalized to same form, see unicode:characters_to_nfX_xxx(..) +%% does casefold on the fly +-spec equal(A, B, IgnoreCase) -> boolean() when + A::unicode:chardata(), + B::unicode:chardata(), + IgnoreCase :: boolean(). +equal(A, B, false) -> + equal(A,B); +equal(A, B, true) -> + equal_nocase(A,B). + +%% Compare two strings return boolean +%% if specified does casefold and normalization on the fly +-spec equal(A, B, IgnoreCase, Norm) -> boolean() when + A :: unicode:chardata(), + B :: unicode:chardata(), + IgnoreCase :: boolean(), + Norm :: 'none' | 'nfc' | 'nfd' | 'nfkc' | 'nfkd'. +equal(A, B, Case, none) -> + equal(A,B,Case); +equal(A, B, false, Norm) -> + equal_norm(A, B, Norm); +equal(A, B, true, Norm) -> + equal_norm_nocase(A, B, Norm). + +%% Reverse grapheme clusters +-spec reverse(String::unicode:chardata()) -> [grapheme_cluster()]. +reverse(<<CP1/utf8, Rest/binary>>) -> + reverse_b(Rest, CP1, []); +reverse(CD) -> + reverse_1(CD, []). + +%% Slice a string and return rest of string +%% Note: counts grapheme_clusters +-spec slice(String, Start) -> Slice when + String::unicode:chardata(), + Start :: non_neg_integer(), + Slice :: unicode:chardata(). +slice(CD, N) when is_integer(N), N >= 0 -> + case slice_l0(CD, N) of + [] when is_binary(CD) -> <<>>; + Res -> Res + end. + +-spec slice(String, Start, Length) -> Slice when + String::unicode:chardata(), + Start :: non_neg_integer(), + Length :: 'infinity' | non_neg_integer(), + Slice :: unicode:chardata(). +slice(CD, N, Length) + when is_integer(N), N >= 0, is_integer(Length), Length > 0 -> + case slice_l0(CD, N) of + [] when is_binary(CD) -> <<>>; + L -> slice_trail(L, Length) + end; +slice(CD, N, infinity) -> + case slice_l0(CD, N) of + [] when is_binary(CD) -> <<>>; + Res -> Res + end; +slice(CD, _, 0) -> + case is_binary(CD) of + true -> <<>>; + false -> [] + end. + +%% Pad a string to desired length +-spec pad(String, Length) -> unicode:charlist() when + String ::unicode:chardata(), + Length :: integer(). +pad(CD, Length) -> + pad(CD, Length, trailing, $\s). + +-spec pad(String, Length, Dir) -> unicode:charlist() when + String ::unicode:chardata(), + Length :: integer(), + Dir :: direction() | 'both'. +pad(CD, Length, Dir) -> + pad(CD, Length, Dir, $\s). + +-spec pad(String, Length, Dir, Char) -> unicode:charlist() when + String ::unicode:chardata(), + Length :: integer(), + Dir :: direction() | 'both', + Char :: grapheme_cluster(). +pad(CD, Length, leading, Char) when is_integer(Length) -> + Len = length(CD), + [lists:duplicate(max(0, Length-Len), Char), CD]; +pad(CD, Length, trailing, Char) when is_integer(Length) -> + Len = length(CD), + [CD|lists:duplicate(max(0, Length-Len), Char)]; +pad(CD, Length, both, Char) when is_integer(Length) -> + Len = length(CD), + Size = max(0, Length-Len), + Pre = lists:duplicate(Size div 2, Char), + Post = case Size rem 2 of + 1 -> [Char]; + _ -> [] + end, + [Pre, CD, Pre|Post]. + +%% Strip characters from whitespace or Separator in Direction +-spec trim(String) -> unicode:chardata() when + String :: unicode:chardata(). +trim(Str) -> + trim(Str, both, unicode_util:whitespace()). + +-spec trim(String, Dir) -> unicode:chardata() when + String :: unicode:chardata(), + Dir :: direction() | 'both'. +trim(Str, Dir) -> + trim(Str, Dir, unicode_util:whitespace()). + +-spec trim(String, Dir, Characters) -> unicode:chardata() when + String :: unicode:chardata(), + Dir :: direction() | 'both', + Characters :: [grapheme_cluster()]. +trim(Str, _, []) -> Str; +trim(Str, leading, [Sep]) when is_list(Str), Sep < 256 -> + trim_ls(Str, Sep); +trim(Str, leading, Sep) when is_list(Sep) -> + trim_l(Str, Sep); +trim(Str, trailing, [Sep]) when is_list(Str), Sep < 256 -> + trim_ts(Str, Sep); +trim(Str, trailing, Seps0) when is_list(Seps0) -> + Seps = search_pattern(Seps0), + trim_t(Str, 0, Seps); +trim(Str, both, Sep) when is_list(Sep) -> + trim(trim(Str,leading,Sep), trailing, Sep). + +%% Delete trailing newlines or \r\n +-spec chomp(String::unicode:chardata()) -> unicode:chardata(). +chomp(Str) -> + trim(Str, trailing, [[$\r,$\n],$\n]). + +%% Split String into two parts where the leading part consists of Characters +-spec take(String, Characters) -> {Leading, Trailing} when + String::unicode:chardata(), + Characters::[grapheme_cluster()], + Leading::unicode:chardata(), + Trailing::unicode:chardata(). +take(Str, Sep) -> + take(Str, Sep, false, leading). +-spec take(String, Characters, Complement) -> {Leading, Trailing} when + String::unicode:chardata(), + Characters::[grapheme_cluster()], + Complement::boolean(), + Leading::unicode:chardata(), + Trailing::unicode:chardata(). +take(Str, Sep, Complement) -> + take(Str, Sep, Complement, leading). +-spec take(String, Characters, Complement, Dir) -> {Leading, Trailing} when + String::unicode:chardata(), + Characters::[grapheme_cluster()], + Complement::boolean(), + Dir::direction(), + Leading::unicode:chardata(), + Trailing::unicode:chardata(). +take(Str, [], Complement, Dir) -> + Empty = case is_binary(Str) of true -> <<>>; false -> [] end, + case {Complement,Dir} of + {false, leading} -> {Empty, Str}; + {false, trailing} -> {Str, Empty}; + {true, leading} -> {Str, Empty}; + {true, trailing} -> {Empty, Str} + end; +take(Str, Sep, false, leading) -> + take_l(Str, Sep, []); +take(Str, Sep0, true, leading) -> + Sep = search_pattern(Sep0), + take_lc(Str, Sep, []); +take(Str, Sep0, false, trailing) -> + Sep = search_pattern(Sep0), + take_t(Str, 0, Sep); +take(Str, Sep0, true, trailing) -> + Sep = search_pattern(Sep0), + take_tc(Str, 0, Sep). + +%% Uppercase all chars in Str +-spec uppercase(String::unicode:chardata()) -> unicode:chardata(). +uppercase(CD) when is_list(CD) -> + uppercase_list(CD); +uppercase(CD) when is_binary(CD) -> + uppercase_bin(CD,<<>>). + +%% Lowercase all chars in Str +-spec lowercase(String::unicode:chardata()) -> unicode:chardata(). +lowercase(CD) when is_list(CD) -> + lowercase_list(CD); +lowercase(CD) when is_binary(CD) -> + lowercase_bin(CD,<<>>). + +%% Make a titlecase of the first char in Str +-spec titlecase(String::unicode:chardata()) -> unicode:chardata(). +titlecase(CD) when is_list(CD) -> + case unicode_util:titlecase(CD) of + [GC|Tail] -> append(GC,Tail); + Empty -> Empty + end; +titlecase(CD) when is_binary(CD) -> + case unicode_util:titlecase(CD) of + [CP|Chars] when is_integer(CP) -> <<CP/utf8,Chars/binary>>; + [CPs|Chars] -> + << << <<CP/utf8>> || CP <- CPs>>/binary, Chars/binary>>; + [] -> <<>> + end. + +%% Make a comparable string of the Str should be used for equality tests only +-spec casefold(String::unicode:chardata()) -> unicode:chardata(). +casefold(CD) when is_list(CD) -> + casefold_list(CD); +casefold(CD) when is_binary(CD) -> + casefold_bin(CD,<<>>). + +-spec to_integer(String) -> {Int, Rest} | {'error', Reason} when + String :: unicode:chardata(), + Int :: integer(), + Rest :: unicode:chardata(), + Reason :: 'no_integer' | badarg. + +to_integer(String) -> + try take(String, "+-0123456789") of + {Head, Tail} -> + case is_empty(Head) of + true -> {error, no_integer}; + false -> + List = unicode:characters_to_list(Head), + case string:list_to_integer(List) of + {error, _} = Err -> Err; + {Int, Rest} -> + to_number(String, Int, Rest, List, Tail) + end + end + catch _:_ -> {error, badarg} + end. + +-spec to_float(String) -> {Float, Rest} | {'error', Reason} when + String :: unicode:chardata(), + Float :: float(), + Rest :: unicode:chardata(), + Reason :: 'no_float' | 'badarg'. + +to_float(String) -> + try take(String, "+-0123456789eE.,") of + {Head, Tail} -> + case is_empty(Head) of + true -> {error, no_float}; + false -> + List = unicode:characters_to_list(Head), + case string:list_to_float(List) of + {error, _} = Err -> Err; + {Float, Rest} -> + to_number(String, Float, Rest, List, Tail) + end + end + catch _:_ -> {error, badarg} + end. + +to_number(String, Number, Rest, List, _Tail) when is_binary(String) -> + BSz = erlang:length(List)-erlang:length(Rest), + <<_:BSz/binary, Cont/binary>> = String, + {Number, Cont}; +to_number(_, Number, Rest, _, Tail) -> + {Number, concat(Rest,Tail)}. + +%% Return the remaining string with prefix removed or else nomatch +-spec prefix(String::unicode:chardata(), Prefix::unicode:chardata()) -> + 'nomatch' | unicode:chardata(). +prefix(Str, Prefix0) -> + Result = case unicode:characters_to_list(Prefix0) of + [] -> Str; + Prefix -> prefix_1(Str, Prefix) + end, + case Result of + [] when is_binary(Str) -> <<>>; + Res -> Res + end. + +%% split String with the first occurrence of SearchPattern, return list of splits +-spec split(String, SearchPattern) -> [unicode:chardata()] when + String :: unicode:chardata(), + SearchPattern :: unicode:chardata(). +split(String, SearchPattern) -> + split(String, SearchPattern, leading). + +%% split String with SearchPattern, return list of splits +-spec split(String, SearchPattern, Where) -> [unicode:chardata()] when + String :: unicode:chardata(), + SearchPattern :: unicode:chardata(), + Where :: direction() | 'all'. +split(String, SearchPattern, Where) -> + case is_empty(SearchPattern) of + true -> [String]; + false -> + SearchPatternCPs = unicode:characters_to_list(SearchPattern), + case split_1(String, SearchPatternCPs, 0, Where, [], []) of + {_Curr, []} -> [String]; + {_Curr, Acc} when Where =:= trailing -> Acc; + {Curr, Acc} when Where =:= all -> lists:reverse([Curr|Acc]); + Acc when is_list(Acc) -> Acc + end + end. + +%% Replace the first SearchPattern in String with Replacement +-spec replace(String, SearchPattern, Replacement) -> + [unicode:chardata()] when + String :: unicode:chardata(), + SearchPattern :: unicode:chardata(), + Replacement :: unicode:chardata(). +replace(String, SearchPattern, Replacement) -> + lists:join(Replacement, split(String, SearchPattern)). + +%% Replace Where SearchPattern in String with Replacement +-spec replace(String, SearchPattern, Replacement, Where) -> + [unicode:chardata()] when + String :: unicode:chardata(), + SearchPattern :: unicode:chardata(), + Replacement :: unicode:chardata(), + Where :: direction() | 'all'. +replace(String, SearchPattern, Replacement, Where) -> + lists:join(Replacement, split(String, SearchPattern, Where)). + +%% Split Str into a list of chardata separated by one of the grapheme +%% clusters in Seps +-spec lexemes(String::unicode:chardata(), + SeparatorList::[grapheme_cluster()]) -> + [unicode:chardata()]. +lexemes([], _) -> []; +lexemes(Str, []) -> [Str]; +lexemes(Str, Seps0) when is_list(Seps0) -> + Seps = search_pattern(Seps0), + lexemes_m(Str, Seps, []). + +-spec nth_lexeme(String, N, SeparatorList) -> unicode:chardata() when + String::unicode:chardata(), + N::non_neg_integer(), + SeparatorList::[grapheme_cluster()]. + +nth_lexeme(Str, 1, []) -> Str; +nth_lexeme(Str, N, Seps0) when is_list(Seps0), is_integer(N), N > 0 -> + Seps = search_pattern(Seps0), + nth_lexeme_m(Str, Seps, N). + +%% find first SearchPattern in String return rest of string +-spec find(String, SearchPattern) -> unicode:chardata() | 'nomatch' when + String::unicode:chardata(), + SearchPattern::unicode:chardata(). +find(String, SearchPattern) -> + find(String, SearchPattern, leading). + +%% find SearchPattern in String (search in Dir direction) return rest of string +-spec find(String, SearchPattern, Dir) -> unicode:chardata() | 'nomatch' when + String::unicode:chardata(), + SearchPattern::unicode:chardata(), + Dir::direction(). +find(String, "", _) -> String; +find(String, <<>>, _) -> String; +find(String, SearchPattern, leading) -> + find_l(String, unicode:characters_to_list(SearchPattern)); +find(String, SearchPattern, trailing) -> + find_r(String, unicode:characters_to_list(SearchPattern), nomatch). + +%% Fetch first grapheme cluster and return rest in tail +-spec next_grapheme(String::unicode:chardata()) -> + maybe_improper_list(grapheme_cluster(),unicode:chardata()) | + {error,unicode:chardata()}. +next_grapheme(CD) -> unicode_util:gc(CD). + +%% Fetch first codepoint and return rest in tail +-spec next_codepoint(String::unicode:chardata()) -> + maybe_improper_list(char(),unicode:chardata()) | + {error,unicode:chardata()}. +next_codepoint(CD) -> unicode_util:cp(CD). + +%% Internals + +length_1([CP1|[CP2|_]=Cont], N) when ?ASCII_LIST(CP1,CP2) -> + length_1(Cont, N+1); +length_1(Str, N) -> + case unicode_util:gc(Str) of + [] -> N; + [_|Rest] -> length_1(Rest, N+1) + end. + +length_b(<<CP2/utf8, Rest/binary>>, CP1, N) + when ?ASCII_LIST(CP1,CP2) -> + length_b(Rest, CP2, N+1); +length_b(Bin0, CP1, N) -> + [_|Bin1] = unicode_util:gc([CP1|Bin0]), + case unicode_util:cp(Bin1) of + [] -> N+1; + [CP3|Bin] -> length_b(Bin, CP3, N+1) + end. + +equal_1([A|AR], [B|BR]) when is_integer(A), is_integer(B) -> + A =:= B andalso equal_1(AR, BR); +equal_1([], BR) -> is_empty(BR); +equal_1(A0,B0) -> + case {unicode_util:cp(A0), unicode_util:cp(B0)} of + {[CP|A],[CP|B]} -> equal_1(A,B); + {[], []} -> true; + {L1,L2} when is_list(L1), is_list(L2) -> false + end. + +equal_nocase(A, A) -> true; +equal_nocase(A0, B0) -> + case {unicode_util:cp(unicode_util:casefold(A0)), + unicode_util:cp(unicode_util:casefold(B0))} of + {[CP|A],[CP|B]} -> equal_nocase(A,B); + {[], []} -> true; + {L1,L2} when is_list(L1), is_list(L2) -> false + end. + +equal_norm(A, A, _Norm) -> true; +equal_norm(A0, B0, Norm) -> + case {unicode_util:cp(unicode_util:Norm(A0)), + unicode_util:cp(unicode_util:Norm(B0))} of + {[CP|A],[CP|B]} -> equal_norm(A,B, Norm); + {[], []} -> true; + {L1,L2} when is_list(L1), is_list(L2) -> false + end. + +equal_norm_nocase(A, A, _Norm) -> true; +equal_norm_nocase(A0, B0, Norm) -> + case {unicode_util:cp(unicode_util:casefold(unicode_util:Norm(A0))), + unicode_util:cp(unicode_util:casefold(unicode_util:Norm(B0)))} of + {[CP|A],[CP|B]} -> equal_norm_nocase(A,B, Norm); + {[], []} -> true; + {L1,L2} when is_list(L1), is_list(L2) -> false + end. + +reverse_1([CP1|[CP2|_]=Cont], Acc) when ?ASCII_LIST(CP1,CP2) -> + reverse_1(Cont, [CP1|Acc]); +reverse_1(CD, Acc) -> + case unicode_util:gc(CD) of + [GC|Rest] -> reverse_1(Rest, [GC|Acc]); + [] -> Acc + end. + +reverse_b(<<CP2/utf8, Rest/binary>>, CP1, Acc) + when ?ASCII_LIST(CP1,CP2) -> + reverse_b(Rest, CP2, [CP1|Acc]); +reverse_b(Bin0, CP1, Acc) -> + [GC|Bin1] = unicode_util:gc([CP1|Bin0]), + case unicode_util:cp(Bin1) of + [] -> [GC|Acc]; + [CP3|Bin] -> reverse_b(Bin, CP3, [GC|Acc]) + end. + +slice_l0(<<CP1/utf8, Bin/binary>>, N) when N > 0 -> + slice_lb(Bin, CP1, N); +slice_l0(L, N) -> + slice_l(L, N). + +slice_l([CP1|[CP2|_]=Cont], N) when ?ASCII_LIST(CP1,CP2),N > 0 -> + slice_l(Cont, N-1); +slice_l(CD, N) when N > 0 -> + case unicode_util:gc(CD) of + [_|Cont] -> slice_l(Cont, N-1); + [] -> [] + end; +slice_l(Cont, 0) -> + Cont. + +slice_lb(<<CP2/utf8, Bin/binary>>, CP1, N) when ?ASCII_LIST(CP1,CP2), N > 1 -> + slice_lb(Bin, CP2, N-1); +slice_lb(Bin, CP1, N) -> + [_|Rest] = unicode_util:gc([CP1|Bin]), + if N > 1 -> + case unicode_util:cp(Rest) of + [CP2|Cont] -> slice_lb(Cont, CP2, N-1); + [] -> <<>> + end; + N =:= 1 -> + Rest + end. + +slice_trail(Orig, N) when is_binary(Orig) -> + case Orig of + <<CP1/utf8, Bin/binary>> when N > 0 -> + Length = slice_bin(Bin, CP1, N), + Sz = byte_size(Orig) - Length, + <<Keep:Sz/binary, _/binary>> = Orig, + Keep; + _ -> <<>> + end; +slice_trail(CD, N) when is_list(CD) -> + slice_list(CD, N). + +slice_list([CP1|[CP2|_]=Cont], N) when ?ASCII_LIST(CP1,CP2),N > 0 -> + [CP1|slice_list(Cont, N-1)]; +slice_list(CD, N) when N > 0 -> + case unicode_util:gc(CD) of + [GC|Cont] -> append(GC, slice_list(Cont, N-1)); + [] -> [] + end; +slice_list(_, 0) -> + []. + +slice_bin(<<CP2/utf8, Bin/binary>>, CP1, N) when ?ASCII_LIST(CP1,CP2), N > 0 -> + slice_bin(Bin, CP2, N-1); +slice_bin(CD, CP1, N) when N > 0 -> + [_|Bin] = unicode_util:gc([CP1|CD]), + case unicode_util:cp(Bin) of + [CP2|Cont] -> slice_bin(Cont, CP2, N-1); + [] -> 0 + end; +slice_bin(CD, CP1, 0) -> + byte_size(CD)+byte_size(<<CP1/utf8>>). + +uppercase_list(CPs0) -> + case unicode_util:uppercase(CPs0) of + [Char|CPs] -> append(Char,uppercase_list(CPs)); + [] -> [] + end. + +uppercase_bin(CPs0, Acc) -> + case unicode_util:uppercase(CPs0) of + [Char|CPs] when is_integer(Char) -> + uppercase_bin(CPs, <<Acc/binary, Char/utf8>>); + [Chars|CPs] -> + uppercase_bin(CPs, <<Acc/binary, + << <<CP/utf8>> || CP <- Chars>>/binary >>); + [] -> Acc + end. + +lowercase_list(CPs0) -> + case unicode_util:lowercase(CPs0) of + [Char|CPs] -> append(Char,lowercase_list(CPs)); + [] -> [] + end. + +lowercase_bin(CPs0, Acc) -> + case unicode_util:lowercase(CPs0) of + [Char|CPs] when is_integer(Char) -> + lowercase_bin(CPs, <<Acc/binary, Char/utf8>>); + [Chars|CPs] -> + lowercase_bin(CPs, <<Acc/binary, + << <<CP/utf8>> || CP <- Chars>>/binary >>); + [] -> Acc + end. + +casefold_list(CPs0) -> + case unicode_util:casefold(CPs0) of + [Char|CPs] -> append(Char, casefold_list(CPs)); + [] -> [] + end. + +casefold_bin(CPs0, Acc) -> + case unicode_util:casefold(CPs0) of + [Char|CPs] when is_integer(Char) -> + casefold_bin(CPs, <<Acc/binary, Char/utf8>>); + [Chars|CPs] -> + casefold_bin(CPs, <<Acc/binary, + << <<CP/utf8>> || CP <- Chars>>/binary >>); + [] -> Acc + end. + +%% Fast path for ascii searching for one character in lists +trim_ls([CP1|[CP2|_]=Cont]=Str, Sep) + when ?ASCII_LIST(CP1,CP2) -> + case Sep of + CP1 -> trim_ls(Cont, Sep); + _ -> Str + end; +trim_ls(Str, Sep) -> + trim_l(Str, [Sep]). + +trim_l([CP1|[CP2|_]=Cont]=Str, Sep) + when ?ASCII_LIST(CP1,CP2) -> + case lists:member(CP1, Sep) of + true -> trim_l(Cont, Sep); + false -> Str + end; +trim_l([Bin|Cont0], Sep) when is_binary(Bin) -> + case bin_search_inv(Bin, Cont0, Sep) of + {nomatch, Cont} -> trim_l(Cont, Sep); + Keep -> Keep + end; +trim_l(Str, Sep) when is_list(Str) -> + case unicode_util:gc(Str) of + [C|Cs] -> + case lists:member(C, Sep) of + true -> trim_l(Cs, Sep); + false -> Str + end; + [] -> [] + end; +trim_l(Bin, Sep) when is_binary(Bin) -> + case bin_search_inv(Bin, [], Sep) of + {nomatch,_} -> <<>>; + [Keep] -> Keep + end. + +%% Fast path for ascii searching for one character in lists +trim_ts([Sep|Cs1]=Str, Sep) -> + case Cs1 of + [] -> []; + [CP2|_] when ?ASCII_LIST(Sep,CP2) -> + Tail = trim_ts(Cs1, Sep), + case is_empty(Tail) of + true -> []; + false -> [Sep|Tail] + end; + _ -> + trim_t(Str, 0, search_pattern([Sep])) + end; +trim_ts([CP|Cont],Sep) when is_integer(CP) -> + [CP|trim_ts(Cont, Sep)]; +trim_ts(Str, Sep) -> + trim_t(Str, 0, search_pattern([Sep])). + +trim_t([CP1|Cont]=Cs0, _, {GCs,CPs,_}=Seps) when is_integer(CP1) -> + case lists:member(CP1, CPs) of + true -> + [GC|Cs1] = unicode_util:gc(Cs0), + case lists:member(GC, GCs) of + true -> + Tail = trim_t(Cs1, 0, Seps), + case is_empty(Tail) of + true -> []; + false -> append(GC,Tail) + end; + false -> + append(GC,trim_t(Cs1, 0, Seps)) + end; + false -> + [CP1|trim_t(Cont, 0, Seps)] + end; +trim_t([Bin|Cont0], N, {GCs,_,_}=Seps0) when is_binary(Bin) -> + <<_:N/binary, Rest/binary>> = Bin, + Seps = search_compile(Seps0), + case bin_search(Rest, Cont0, Seps) of + {nomatch,_} -> + stack(Bin, trim_t(Cont0, 0, Seps)); + [SepStart|Cont1] -> + case bin_search_inv(SepStart, Cont1, GCs) of + {nomatch, Cont} -> + Tail = trim_t(Cont, 0, Seps), + case is_empty(Tail) of + true -> + KeepSz = byte_size(Bin) - byte_size(SepStart), + <<Keep:KeepSz/binary, _/binary>> = Bin, + Keep; + false -> + Used = cp_prefix(Cont0, Cont), + stack(Bin, stack(Used, Tail)) + end; + [NonSep|Cont] when is_binary(NonSep) -> + KeepSz = byte_size(Bin) - byte_size(NonSep), + trim_t([Bin|Cont], KeepSz, Seps) + end + end; +trim_t(Str, 0, {GCs,_,_}=Seps) when is_list(Str) -> + case unicode_util:gc(Str) of + [GC|Cs1] -> + case lists:member(GC, GCs) of + true -> + Tail = trim_t(Cs1, 0, Seps), + case is_empty(Tail) of + true -> []; + false -> append(GC,Tail) + end; + false -> + append(GC,trim_t(Cs1, 0, Seps)) + end; + [] -> [] + end; +trim_t(Bin, N, {GCs,_,_}=Seps0) when is_binary(Bin) -> + <<_:N/binary, Rest/binary>> = Bin, + Seps = search_compile(Seps0), + case bin_search(Rest, [], Seps) of + {nomatch,_} -> Bin; + [SepStart] -> + case bin_search_inv(SepStart, [], GCs) of + {nomatch,_} -> + KeepSz = byte_size(Bin) - byte_size(SepStart), + <<Keep:KeepSz/binary, _/binary>> = Bin, + Keep; + [NonSep] -> + KeepSz = byte_size(Bin) - byte_size(NonSep), + trim_t(Bin, KeepSz, Seps) + end + end. + + +take_l([CP1|[CP2|_]=Cont]=Str, Seps, Acc) + when ?ASCII_LIST(CP1,CP2) -> + case lists:member(CP1, Seps) of + true -> take_l(Cont, Seps, [CP1|Acc]); + false -> {rev(Acc), Str} + end; +take_l([Bin|Cont0], Seps, Acc) when is_binary(Bin) -> + case bin_search_inv(Bin, Cont0, Seps) of + {nomatch, Cont} -> + Used = cp_prefix(Cont0, Cont), + take_l(Cont, Seps, [unicode:characters_to_binary([Bin|Used])|Acc]); + [Bin1|_]=After when is_binary(Bin1) -> + First = byte_size(Bin) - byte_size(Bin1), + <<Keep:First/binary, _/binary>> = Bin, + {btoken(Keep,Acc), After} + end; +take_l(Str, Seps, Acc) when is_list(Str) -> + case unicode_util:gc(Str) of + [C|Cs] -> + case lists:member(C, Seps) of + true -> take_l(Cs, Seps, append(rev(C),Acc)); + false -> {rev(Acc), Str} + end; + [] -> {rev(Acc), []} + end; +take_l(Bin, Seps, Acc) when is_binary(Bin) -> + case bin_search_inv(Bin, [], Seps) of + {nomatch,_} -> + {btoken(Bin, Acc), <<>>}; + [After] -> + First = byte_size(Bin) - byte_size(After), + <<Keep:First/binary, _/binary>> = Bin, + {btoken(Keep, Acc), After} + end. + + +take_lc([CP1|Cont]=Str0, {GCs,CPs,_}=Seps, Acc) when is_integer(CP1) -> + case lists:member(CP1, CPs) of + true -> + [GC|Str] = unicode_util:gc(Str0), + case lists:member(GC, GCs) of + false -> take_lc(Str, Seps, append(rev(GC),Acc)); + true -> {rev(Acc), Str0} + end; + false -> + take_lc(Cont, Seps, append(CP1,Acc)) + end; +take_lc([Bin|Cont0], Seps0, Acc) when is_binary(Bin) -> + Seps = search_compile(Seps0), + case bin_search(Bin, Cont0, Seps) of + {nomatch, Cont} -> + Used = cp_prefix(Cont0, Cont), + take_lc(Cont, Seps, [unicode:characters_to_binary([Bin|Used])|Acc]); + [Bin1|_]=After when is_binary(Bin1) -> + First = byte_size(Bin) - byte_size(Bin1), + <<Keep:First/binary, _/binary>> = Bin, + {btoken(Keep,Acc), After} + end; +take_lc(Str, {GCs,_,_}=Seps, Acc) when is_list(Str) -> + case unicode_util:gc(Str) of + [C|Cs] -> + case lists:member(C, GCs) of + false -> take_lc(Cs, Seps, append(rev(C),Acc)); + true -> {rev(Acc), Str} + end; + [] -> {rev(Acc), []} + end; +take_lc(Bin, Seps0, Acc) when is_binary(Bin) -> + Seps = search_compile(Seps0), + case bin_search(Bin, [], Seps) of + {nomatch,_} -> + {btoken(Bin, Acc), <<>>}; + [After] -> + First = byte_size(Bin) - byte_size(After), + <<Keep:First/binary, _/binary>> = Bin, + {btoken(Keep, Acc), After} + end. + + +take_t([CP1|Cont]=Str0, _, {GCs,CPs,_}=Seps) when is_integer(CP1) -> + case lists:member(CP1, CPs) of + true -> + [GC|Str] = unicode_util:gc(Str0), + case lists:member(GC, GCs) of + true -> + {Head, Tail} = take_t(Str, 0, Seps), + case is_empty(Head) of + true -> {Head, append(GC,Tail)}; + false -> {append(GC,Head), Tail} + end; + false -> + {Head, Tail} = take_t(Str, 0, Seps), + {append(GC,Head), Tail} + end; + false -> + {Head, Tail} = take_t(Cont, 0, Seps), + {[CP1|Head], Tail} + end; +take_t([Bin|Cont0], N, {GCs,_,_}=Seps0) when is_binary(Bin) -> + <<_:N/binary, Rest/binary>> = Bin, + Seps = search_compile(Seps0), + case bin_search(Rest, Cont0, Seps) of + {nomatch,Cont} -> + Used = cp_prefix(Cont0, Cont), + {Head, Tail} = take_t(Cont, 0, Seps), + {stack(unicode:characters_to_binary([Bin|Used]), Head), Tail}; + [SepStart|Cont1] -> + case bin_search_inv(SepStart, Cont1, GCs) of + {nomatch, Cont} -> + {Head, Tail} = take_t(Cont, 0, Seps), + Used = cp_prefix(Cont0, Cont), + case is_empty(Head) of + true -> + KeepSz = byte_size(Bin) - byte_size(SepStart), + <<Keep:KeepSz/binary, End/binary>> = Bin, + {Keep, stack(stack(End,Used),Tail)}; + false -> + {stack(unicode:characters_to_binary([Bin|Used]),Head), Tail} + end; + [NonSep|Cont] when is_binary(NonSep) -> + KeepSz = byte_size(Bin) - byte_size(NonSep), + take_t([Bin|Cont], KeepSz, Seps) + end + end; +take_t(Str, 0, {GCs,_,_}=Seps) when is_list(Str) -> + case unicode_util:gc(Str) of + [GC|Cs1] -> + case lists:member(GC, GCs) of + true -> + {Head, Tail} = take_t(Cs1, 0, Seps), + case is_empty(Head) of + true -> {Head, append(GC,Tail)}; + false -> {append(GC,Head), Tail} + end; + false -> + {Head, Tail} = take_t(Cs1, 0, Seps), + {append(GC,Head), Tail} + end; + [] -> {[],[]} + end; +take_t(Bin, N, {GCs,_,_}=Seps0) when is_binary(Bin) -> + <<_:N/binary, Rest/binary>> = Bin, + Seps = search_compile(Seps0), + case bin_search(Rest, [], Seps) of + {nomatch,_} -> {Bin, <<>>}; + [SepStart] -> + case bin_search_inv(SepStart, [], GCs) of + {nomatch,_} -> + KeepSz = byte_size(Bin) - byte_size(SepStart), + <<Before:KeepSz/binary, End/binary>> = Bin, + {Before, End}; + [NonSep] -> + KeepSz = byte_size(Bin) - byte_size(NonSep), + take_t(Bin, KeepSz, Seps) + end + end. + +take_tc([CP1|[CP2|_]=Cont], _, {GCs,_,_}=Seps) when ?ASCII_LIST(CP1,CP2) -> + case lists:member(CP1, GCs) of + false -> + {Head, Tail} = take_tc(Cont, 0, Seps), + case is_empty(Head) of + true -> {Head, append(CP1,Tail)}; + false -> {append(CP1,Head), Tail} + end; + true -> + {Head, Tail} = take_tc(Cont, 0, Seps), + {append(CP1,Head), Tail} + end; +take_tc([Bin|Cont0], N, {GCs,_,_}=Seps0) when is_binary(Bin) -> + <<_:N/binary, Rest/binary>> = Bin, + case bin_search_inv(Rest, Cont0, GCs) of + {nomatch,Cont} -> + Used = cp_prefix(Cont0, Cont), + {Head, Tail} = take_tc(Cont, 0, Seps0), + {stack(unicode:characters_to_binary([Bin|Used]), Head), Tail}; + [SepStart|Cont1] -> + Seps = search_compile(Seps0), + case bin_search(SepStart, Cont1, Seps) of + {nomatch, Cont} -> + {Head, Tail} = take_tc(Cont, 0, Seps), + Used = cp_prefix(Cont0, Cont), + case is_empty(Head) of + true -> + KeepSz = byte_size(Bin) - byte_size(SepStart), + <<Keep:KeepSz/binary, End/binary>> = Bin, + {Keep, stack(stack(End,Used),Tail)}; + false -> + {stack(unicode:characters_to_binary([Bin|Used]),Head), Tail} + end; + [NonSep|Cont] when is_binary(NonSep) -> + KeepSz = byte_size(Bin) - byte_size(NonSep), + take_tc([Bin|Cont], KeepSz, Seps) + end + end; +take_tc(Str, 0, {GCs,_,_}=Seps) when is_list(Str) -> + case unicode_util:gc(Str) of + [GC|Cs1] -> + case lists:member(GC, GCs) of + false -> + {Head, Tail} = take_tc(Cs1, 0, Seps), + case is_empty(Head) of + true -> {Head, append(GC,Tail)}; + false -> {append(GC,Head), Tail} + end; + true -> + {Head, Tail} = take_tc(Cs1, 0, Seps), + {append(GC,Head), Tail} + end; + [] -> {[],[]} + end; +take_tc(Bin, N, {GCs,_,_}=Seps0) when is_binary(Bin) -> + <<_:N/binary, Rest/binary>> = Bin, + case bin_search_inv(Rest, [], GCs) of + {nomatch,_} -> {Bin, <<>>}; + [SepStart] -> + Seps = search_compile(Seps0), + case bin_search(SepStart, [], Seps) of + {nomatch,_} -> + KeepSz = byte_size(Bin) - byte_size(SepStart), + <<Before:KeepSz/binary, End/binary>> = Bin, + {Before, End}; + [NonSep] -> + KeepSz = byte_size(Bin) - byte_size(NonSep), + take_tc(Bin, KeepSz, Seps) + end + end. + +prefix_1(Cs0, [GC]) -> + case unicode_util:gc(Cs0) of + [GC|Cs] -> Cs; + _ -> nomatch + end; +prefix_1([CP|Cs], [Pre|PreR]) when is_integer(CP) -> + case CP =:= Pre of + true -> prefix_1(Cs,PreR); + false -> nomatch + end; +prefix_1(<<CP/utf8, Cs/binary>>, [Pre|PreR]) -> + case CP =:= Pre of + true -> prefix_1(Cs,PreR); + false -> nomatch + end; +prefix_1(Cs0, [Pre|PreR]) -> + case unicode_util:cp(Cs0) of + [Pre|Cs] -> prefix_1(Cs,PreR); + _ -> nomatch + end. + +split_1([CP1|Cs]=Cs0, [C|_]=Needle, _, Where, Curr, Acc) when is_integer(CP1) -> + case CP1=:=C of + true -> + case prefix_1(Cs0, Needle) of + nomatch -> split_1(Cs, Needle, 0, Where, append(C,Curr), Acc); + Rest when Where =:= leading -> + [rev(Curr), Rest]; + Rest when Where =:= trailing -> + split_1(Cs, Needle, 0, Where, [C|Curr], [rev(Curr), Rest]); + Rest when Where =:= all -> + split_1(Rest, Needle, 0, Where, [], [rev(Curr)|Acc]) + end; + false -> + split_1(Cs, Needle, 0, Where, append(CP1,Curr), Acc) + end; +split_1([Bin|Cont0], Needle, Start, Where, Curr0, Acc) + when is_binary(Bin) -> + case bin_search_str(Bin, Start, Cont0, Needle) of + {nomatch,Sz,Cont} -> + <<Keep:Sz/binary, _/binary>> = Bin, + split_1(Cont, Needle, 0, Where, [Keep|Curr0], Acc); + {Before, [Cs0|Cont], After} -> + Curr = add_non_empty(Before,Curr0), + case Where of + leading -> + [rev(Curr),After]; + trailing -> + <<_/utf8, Cs/binary>> = Cs0, + Next = byte_size(Bin) - byte_size(Cs), + split_1([Bin|Cont], Needle, Next, Where, + Curr0, [rev(Curr),After]); + all -> + split_1(After, Needle, 0, Where, [], [rev(Curr)|Acc]) + end + end; +split_1(Cs0, [C|_]=Needle, _, Where, Curr, Acc) when is_list(Cs0) -> + case unicode_util:cp(Cs0) of + [C|Cs] -> + case prefix_1(Cs0, Needle) of + nomatch -> split_1(Cs, Needle, 0, Where, append(C,Curr), Acc); + Rest when Where =:= leading -> + [rev(Curr), Rest]; + Rest when Where =:= trailing -> + split_1(Cs, Needle, 0, Where, [C|Curr], [rev(Curr), Rest]); + Rest when Where =:= all -> + split_1(Rest, Needle, 0, Where, [], [rev(Curr)|Acc]) + end; + [Other|Cs] -> + split_1(Cs, Needle, 0, Where, append(Other,Curr), Acc); + [] -> + {rev(Curr), Acc} + end; +split_1(Bin, [_C|_]=Needle, Start, Where, Curr0, Acc) -> + case bin_search_str(Bin, Start, [], Needle) of + {nomatch,_,_} -> + <<_:Start/binary, Keep/binary>> = Bin, + {rev([Keep|Curr0]), Acc}; + {Before, [Cs0], After} -> + case Where of + leading -> + [rev([Before|Curr0]),After]; + trailing -> + <<_/utf8, Cs/binary>> = Cs0, + Next = byte_size(Bin) - byte_size(Cs), + split_1(Bin, Needle, Next, Where, Curr0, + [btoken(Before,Curr0),After]); + all -> + Next = byte_size(Bin) - byte_size(After), + <<_:Start/binary, Keep/binary>> = Before, + Curr = [Keep|Curr0], + split_1(Bin, Needle, Next, Where, [], [rev(Curr)|Acc]) + end + end. + +lexemes_m([CP|_]=Cs0, {GCs,CPs,_}=Seps, Ts) when is_integer(CP) -> + case lists:member(CP, CPs) of + true -> + [GC|Cs2] = unicode_util:gc(Cs0), + case lists:member(GC, GCs) of + true -> + lexemes_m(Cs2, Seps, Ts); + false -> + {Lexeme,Rest} = lexeme_pick(Cs0, Seps, []), + lexemes_m(Rest, Seps, [Lexeme|Ts]) + end; + false -> + {Lexeme,Rest} = lexeme_pick(Cs0, Seps, []), + lexemes_m(Rest, Seps, [Lexeme|Ts]) + end; +lexemes_m([Bin|Cont0], {GCs,_,_}=Seps0, Ts) when is_binary(Bin) -> + case bin_search_inv(Bin, Cont0, GCs) of + {nomatch,Cont} -> + lexemes_m(Cont, Seps0, Ts); + Cs -> + Seps = search_compile(Seps0), + {Lexeme,Rest} = lexeme_pick(Cs, Seps, []), + lexemes_m(Rest, Seps, [Lexeme|Ts]) + end; +lexemes_m(Cs0, {GCs, _, _}=Seps0, Ts) when is_list(Cs0) -> + case unicode_util:gc(Cs0) of + [C|Cs] -> + case lists:member(C, GCs) of + true -> + lexemes_m(Cs, Seps0, Ts); + false -> + Seps = search_compile(Seps0), + {Lexeme,Rest} = lexeme_pick(Cs0, Seps, []), + lexemes_m(Rest, Seps, [Lexeme|Ts]) + end; + [] -> + lists:reverse(Ts) + end; +lexemes_m(Bin, {GCs,_,_}=Seps0, Ts) when is_binary(Bin) -> + case bin_search_inv(Bin, [], GCs) of + {nomatch,_} -> + lists:reverse(Ts); + [Cs] -> + Seps = search_compile(Seps0), + {Lexeme,Rest} = lexeme_pick(Cs, Seps, []), + lexemes_m(Rest, Seps, add_non_empty(Lexeme,Ts)) + end. + +lexeme_pick([CP|Cs1]=Cs0, {GCs,CPs,_}=Seps, Tkn) when is_integer(CP) -> + case lists:member(CP, CPs) of + true -> + [GC|Cs2] = unicode_util:gc(Cs0), + case lists:member(GC, GCs) of + true -> {rev(Tkn), Cs2}; + false -> lexeme_pick(Cs2, Seps, append(rev(GC),Tkn)) + end; + false -> lexeme_pick(Cs1, Seps, [CP|Tkn]) + end; +lexeme_pick([Bin|Cont0], Seps, Tkn) when is_binary(Bin) -> + case bin_search(Bin, Cont0, Seps) of + {nomatch,_} -> + lexeme_pick(Cont0, Seps, [Bin|Tkn]); + [Left|_Cont] = Cs -> + Bytes = byte_size(Bin) - byte_size(Left), + <<Lexeme:Bytes/binary, _/binary>> = Bin, + {btoken(Lexeme, Tkn), Cs} + end; +lexeme_pick(Cs0, {GCs, CPs, _} = Seps, Tkn) when is_list(Cs0) -> + case unicode_util:cp(Cs0) of + [CP|Cs] -> + case lists:member(CP, CPs) of + true -> + [GC|Cs2] = unicode_util:gc(Cs0), + case lists:member(GC, GCs) of + true -> {rev(Tkn), Cs2}; + false -> lexeme_pick(Cs2, Seps, append(rev(GC),Tkn)) + end; + false -> + lexeme_pick(Cs, Seps, append(CP,Tkn)) + end; + [] -> + {rev(Tkn), []} + end; +lexeme_pick(Bin, Seps, Tkn) when is_binary(Bin) -> + case bin_search(Bin, [], Seps) of + {nomatch,_} -> + {btoken(Bin,Tkn), []}; + [Left] -> + Bytes = byte_size(Bin) - byte_size(Left), + <<Lexeme:Bytes/binary, _/binary>> = Bin, + {btoken(Lexeme, Tkn), Left} + end. + +nth_lexeme_m([Bin|Cont0], {GCs,_,_}=Seps0, N) when is_binary(Bin) -> + case bin_search_inv(Bin, Cont0, GCs) of + {nomatch,Cont} -> + nth_lexeme_m(Cont, Seps0, N); + Cs when N > 1 -> + Rest = lexeme_skip(Cs, Seps0), + nth_lexeme_m(Rest, Seps0, N-1); + Cs -> + Seps = search_compile(Seps0), + {Lexeme,_} = lexeme_pick(Cs, Seps, []), + Lexeme + end; +nth_lexeme_m(Cs0, {GCs, _, _}=Seps0, N) when is_list(Cs0) -> + case unicode_util:gc(Cs0) of + [C|Cs] -> + case lists:member(C, GCs) of + true -> + nth_lexeme_m(Cs, Seps0, N); + false when N > 1 -> + Cs1 = lexeme_skip(Cs, Seps0), + nth_lexeme_m(Cs1, Seps0, N-1); + false -> + Seps = search_compile(Seps0), + {Lexeme,_} = lexeme_pick(Cs0, Seps, []), + Lexeme + end; + [] -> + [] + end; +nth_lexeme_m(Bin, {GCs,_,_}=Seps0, N) when is_binary(Bin) -> + Seps = search_compile(Seps0), + case bin_search_inv(Bin, [], GCs) of + [Cs] when N > 1 -> + Cs1 = lexeme_skip(Cs, Seps), + nth_lexeme_m(Cs1, Seps, N-1); + [Cs] -> + {Lexeme,_} = lexeme_pick(Cs, Seps, []), + Lexeme; + {nomatch,_} -> + <<>> + end. + +lexeme_skip([CP|Cs1]=Cs0, {GCs,CPs,_}=Seps) when is_integer(CP) -> + case lists:member(CP, CPs) of + true -> + [GC|Cs2] = unicode_util:gc(Cs0), + case lists:member(GC, GCs) of + true -> Cs2; + false -> lexeme_skip(Cs2, Seps) + end; + false -> + lexeme_skip(Cs1, Seps) + end; +lexeme_skip([Bin|Cont0], Seps0) when is_binary(Bin) -> + Seps = search_compile(Seps0), + case bin_search(Bin, Cont0, Seps) of + {nomatch,_} -> lexeme_skip(Cont0, Seps); + Cs -> tl(unicode_util:gc(Cs)) + end; +lexeme_skip(Cs0, {GCs, CPs, _} = Seps) when is_list(Cs0) -> + case unicode_util:cp(Cs0) of + [CP|Cs] -> + case lists:member(CP, CPs) of + true -> + [GC|Cs2] = unicode_util:gc(Cs0), + case lists:member(GC, GCs) of + true -> Cs2; + false -> lexeme_skip(Cs2, Seps) + end; + false -> + lexeme_skip(Cs, Seps) + end; + [] -> + [] + end; +lexeme_skip(Bin, Seps0) when is_binary(Bin) -> + Seps = search_compile(Seps0), + case bin_search(Bin, [], Seps) of + {nomatch,_} -> <<>>; + [Left] -> tl(unicode_util:gc(Left)) + end. + +find_l([C1|Cs]=Cs0, [C|_]=Needle) when is_integer(C1) -> + case C1 of + C -> + case prefix_1(Cs0, Needle) of + nomatch -> find_l(Cs, Needle); + _ -> Cs0 + end; + _ -> + find_l(Cs, Needle) + end; +find_l([Bin|Cont0], Needle) when is_binary(Bin) -> + case bin_search_str(Bin, 0, Cont0, Needle) of + {nomatch, _, Cont} -> + find_l(Cont, Needle); + {_Before, Cs, _After} -> + Cs + end; +find_l(Cs0, [C|_]=Needle) when is_list(Cs0) -> + case unicode_util:cp(Cs0) of + [C|Cs] -> + case prefix_1(Cs0, Needle) of + nomatch -> find_l(Cs, Needle); + _ -> Cs0 + end; + [_C|Cs] -> + find_l(Cs, Needle); + [] -> nomatch + end; +find_l(Bin, Needle) -> + case bin_search_str(Bin, 0, [], Needle) of + {nomatch,_,_} -> nomatch; + {_Before, [Cs], _After} -> Cs + end. + +find_r([Cp|Cs]=Cs0, [C|_]=Needle, Res) when is_integer(Cp) -> + case Cp of + C -> + case prefix_1(Cs0, Needle) of + nomatch -> find_r(Cs, Needle, Res); + _ -> find_r(Cs, Needle, Cs0) + end; + _ -> + find_r(Cs, Needle, Res) + end; +find_r([Bin|Cont0], Needle, Res) when is_binary(Bin) -> + case bin_search_str(Bin, 0, Cont0, Needle) of + {nomatch,_,Cont} -> + find_r(Cont, Needle, Res); + {_, Cs0, _} -> + [_|Cs] = unicode_util:gc(Cs0), + find_r(Cs, Needle, Cs0) + end; +find_r(Cs0, [C|_]=Needle, Res) when is_list(Cs0) -> + case unicode_util:cp(Cs0) of + [C|Cs] -> + case prefix_1(Cs0, Needle) of + nomatch -> find_r(Cs, Needle, Res); + _ -> find_r(Cs, Needle, Cs0) + end; + [_C|Cs] -> + find_r(Cs, Needle, Res); + [] -> Res + end; +find_r(Bin, Needle, Res) -> + case bin_search_str(Bin, 0, [], Needle) of + {nomatch,_,_} -> Res; + {_Before, [Cs0], _After} -> + <<_/utf8, Cs/binary>> = Cs0, + find_r(Cs, Needle, Cs0) + end. + +%% These are used to avoid creating lists around binaries +%% might be unnecessary, is there a better solution? +btoken(Token, []) -> Token; +btoken(BinPart, [C]) when is_integer(C) -> <<C/utf8, BinPart/binary>>; +btoken(<<>>, Tkn) -> lists:reverse(Tkn); +btoken(BinPart, Cs) -> [lists:reverse(Cs),BinPart]. + +rev([B]) when is_binary(B) -> B; +rev(L) when is_list(L) -> lists:reverse(L); +rev(C) when is_integer(C) -> C. + +append(Char, <<>>) when is_integer(Char) -> [Char]; +append(Char, <<>>) when is_list(Char) -> Char; +append(Char, Bin) when is_binary(Bin) -> [Char,Bin]; +append(Char, Str) when is_integer(Char) -> [Char|Str]; +append(GC, Str) when is_list(GC) -> GC ++ Str. + +stack(Bin, []) -> Bin; +stack(<<>>, St) -> St; +stack([], St) -> St; +stack(Bin, St) -> [Bin|St]. + +add_non_empty(<<>>, L) -> L; +add_non_empty(Token, L) -> [Token|L]. + +cp_prefix(Orig, Cont) -> + case unicode_util:cp(Cont) of + [] -> Orig; + [Cp|Rest] -> cp_prefix_1(Orig, Cp, Rest) + end. + +cp_prefix_1(Orig, Until, Cont) -> + case unicode_util:cp(Orig) of + [Until|Rest] -> + case equal(Rest, Cont) of + true -> []; + false-> [Until|cp_prefix_1(Rest, Until, Cont)] + end; + [CP|Rest] -> [CP|cp_prefix_1(Rest, Until, Cont)] + end. + + +%% Binary special +bin_search(Bin, Cont, {Seps,_,BP}) -> + bin_search_loop(Bin, 0, BP, Cont, Seps). + +%% Need to work with [<<$a>>, <<778/utf8>>], +%% i.e. å in nfd form $a "COMBINING RING ABOVE" +%% and PREPEND characters like "ARABIC NUMBER SIGN" 1536 <<216,128>> +%% combined with other characters are currently ignored. +search_pattern({_,_,_}=P) -> P; +search_pattern(Seps) -> + CPs = search_cp(Seps), + {Seps, CPs, undefined}. + +search_compile({Sep, CPs, undefined}) -> + {Sep, CPs, binary:compile_pattern(bin_pattern(CPs))}; +search_compile({_,_,_}=Compiled) -> Compiled. + +search_cp([CP|Seps]) when is_integer(CP) -> + [CP|search_cp(Seps)]; +search_cp([Pattern|Seps]) -> + [CP|_] = unicode_util:cp(Pattern), + [CP|search_cp(Seps)]; +search_cp([]) -> []. + +bin_pattern([CP|Seps]) -> + [<<CP/utf8>>|bin_pattern(Seps)]; +bin_pattern([]) -> []. + +bin_search_loop(Bin0, Start, _, Cont, _Seps) + when byte_size(Bin0) =< Start; Start < 0 -> + {nomatch, Cont}; +bin_search_loop(Bin0, Start, BinSeps, Cont, Seps) -> + <<_:Start/binary, Bin/binary>> = Bin0, + case binary:match(Bin, BinSeps) of + nomatch -> + {nomatch,Cont}; + {Where, _CL} when Cont =:= [] -> + <<_:Where/binary, Cont1/binary>> = Bin, + [GC|Cont2] = unicode_util:gc(Cont1), + case lists:member(GC, Seps) of + false when Cont2 =:= [] -> + {nomatch, []}; + false -> + Next = byte_size(Bin0) - byte_size(Cont2), + bin_search_loop(Bin0, Next, BinSeps, Cont, Seps); + true -> + [Cont1] + end; + {Where, _CL} -> + <<_:Where/binary, Cont0/binary>> = Bin, + Cont1 = [Cont0|Cont], + [GC|Cont2] = unicode_util:gc(Cont1), + case lists:member(GC, Seps) of + false -> + case Cont2 of + [BinR|Cont] when is_binary(BinR) -> + Next = byte_size(Bin0) - byte_size(BinR), + bin_search_loop(Bin0, Next, BinSeps, Cont, Seps); + _ -> + {nomatch, Cont2} + end; + true -> + Cont1 + end + end. + +bin_search_inv(<<>>, Cont, _) -> + {nomatch, Cont}; +bin_search_inv(Bin, Cont, [Sep]) -> + bin_search_inv_1(Bin, Cont, Sep); +bin_search_inv(Bin, Cont, Seps) -> + bin_search_inv_n(Bin, Cont, Seps). + +bin_search_inv_1(<<CP1/utf8, BinRest/binary>>=Bin0, Cont, Sep) -> + case BinRest of + <<CP2/utf8, _/binary>> when ?ASCII_LIST(CP1, CP2) -> + case CP1 of + Sep -> bin_search_inv_1(BinRest, Cont, Sep); + _ -> [Bin0|Cont] + end; + _ when Cont =:= [] -> + case unicode_util:gc(Bin0) of + [Sep|Bin] -> bin_search_inv_1(Bin, Cont, Sep); + _ -> [Bin0|Cont] + end; + _ -> + case unicode_util:gc([Bin0|Cont]) of + [Sep|[Bin|Cont]] when is_binary(Bin) -> + bin_search_inv_1(Bin, Cont, Sep); + [Sep|Cs] -> + {nomatch, Cs}; + _ -> [Bin0|Cont] + end + end; +bin_search_inv_1(<<>>, Cont, _Sep) -> + {nomatch, Cont}; +bin_search_inv_1([], Cont, _Sep) -> + {nomatch, Cont}. + + +bin_search_inv_n(<<CP1/utf8, BinRest/binary>>=Bin0, Cont, Seps) -> + case BinRest of + <<CP2/utf8, _/binary>> when ?ASCII_LIST(CP1, CP2) -> + case lists:member(CP1,Seps) of + true -> bin_search_inv_n(BinRest, Cont, Seps); + false -> [Bin0|Cont] + end; + _ when Cont =:= [] -> + [GC|Bin] = unicode_util:gc(Bin0), + case lists:member(GC, Seps) of + true -> bin_search_inv_n(Bin, Cont, Seps); + false -> [Bin0|Cont] + end; + _ -> + [GC|Cs0] = unicode_util:gc([Bin0|Cont]), + case lists:member(GC, Seps) of + false -> [Bin0|Cont]; + true -> + case Cs0 of + [Bin|Cont] when is_binary(Bin) -> + bin_search_inv_n(Bin, Cont, Seps); + _ -> + {nomatch, Cs0} + end + end + end; +bin_search_inv_n(<<>>, Cont, _Sep) -> + {nomatch, Cont}; +bin_search_inv_n([], Cont, _Sep) -> + {nomatch, Cont}. + +bin_search_str(Bin0, Start, [], SearchCPs) -> + Compiled = binary:compile_pattern(unicode:characters_to_binary(SearchCPs)), + bin_search_str_1(Bin0, Start, Compiled, SearchCPs); +bin_search_str(Bin0, Start, Cont, [CP|_]=SearchCPs) -> + First = binary:compile_pattern(<<CP/utf8>>), + bin_search_str_2(Bin0, Start, Cont, First, SearchCPs). + +bin_search_str_1(Bin0, Start, First, SearchCPs) -> + <<_:Start/binary, Bin/binary>> = Bin0, + case binary:match(Bin, First) of + nomatch -> {nomatch, byte_size(Bin0), []}; + {Where0, _} -> + Where = Start+Where0, + <<Keep:Where/binary, Cs0/binary>> = Bin0, + case prefix_1(Cs0, SearchCPs) of + nomatch -> + <<_/utf8, Cs/binary>> = Cs0, + KeepSz = byte_size(Bin0) - byte_size(Cs), + bin_search_str_1(Bin0, KeepSz, First, SearchCPs); + [] -> + {Keep, [Cs0], <<>>}; + Rest -> + {Keep, [Cs0], Rest} + end + end. + +bin_search_str_2(Bin0, Start, Cont, First, SearchCPs) -> + <<_:Start/binary, Bin/binary>> = Bin0, + case binary:match(Bin, First) of + nomatch -> {nomatch, byte_size(Bin0), Cont}; + {Where0, _} -> + Where = Start+Where0, + <<Keep:Where/binary, Cs0/binary>> = Bin0, + [GC|Cs]=unicode_util:gc(Cs0), + case prefix_1(stack(Cs0,Cont), SearchCPs) of + nomatch when is_binary(Cs) -> + KeepSz = byte_size(Bin0) - byte_size(Cs), + bin_search_str_2(Bin0, KeepSz, Cont, First, SearchCPs); + nomatch -> + {nomatch, Where, stack([GC|Cs],Cont)}; + [] -> + {Keep, [Cs0|Cont], <<>>}; + Rest -> + {Keep, [Cs0|Cont], Rest} + end + end. + + +%%--------------------------------------------------------------------------- +%% OLD lists API kept for backwards compability +%%--------------------------------------------------------------------------- + %% Robert's bit %% len(String) @@ -63,17 +1632,17 @@ to_integer(_) -> String :: string(), Length :: non_neg_integer(). -len(S) -> length(S). +len(S) -> erlang:length(S). %% equal(String1, String2) %% Test if 2 strings are equal. --spec equal(String1, String2) -> boolean() when - String1 :: string(), - String2 :: string(). +%% -spec equal(String1, String2) -> boolean() when +%% String1 :: string(), +%% String2 :: string(). -equal(S, S) -> true; -equal(_, _) -> false. +%% equal(S, S) -> true; +%% equal(_, _) -> false. %% concat(String1, String2) %% Concatenate 2 strings. @@ -127,7 +1696,7 @@ rchr([], _C, _I, L) -> L. str(S, Sub) when is_list(Sub) -> str(S, Sub, 1). str([C|S], [C|Sub], I) -> - case prefix(Sub, S) of + case l_prefix(Sub, S) of true -> I; false -> str(S, [C|Sub], I+1) end; @@ -142,16 +1711,16 @@ str([], _Sub, _I) -> 0. rstr(S, Sub) when is_list(Sub) -> rstr(S, Sub, 1, 0). rstr([C|S], [C|Sub], I, L) -> - case prefix(Sub, S) of + case l_prefix(Sub, S) of true -> rstr(S, [C|Sub], I+1, I); false -> rstr(S, [C|Sub], I+1, L) end; rstr([_|S], Sub, I, L) -> rstr(S, Sub, I+1, L); rstr([], _Sub, _I, L) -> L. -prefix([C|Pre], [C|String]) -> prefix(Pre, String); -prefix([], String) when is_list(String) -> true; -prefix(Pre, String) when is_list(Pre), is_list(String) -> false. +l_prefix([C|Pre], [C|String]) -> l_prefix(Pre, String); +l_prefix([], String) when is_list(String) -> true; +l_prefix(Pre, String) when is_list(Pre), is_list(String) -> false. %% span(String, Chars) -> Length. %% cspan(String, Chars) -> Length. @@ -229,9 +1798,9 @@ tokens(S, Seps) -> [_|_] -> [S] end; [C] -> - tokens_single_1(reverse(S), C, []); + tokens_single_1(lists:reverse(S), C, []); [_|_] -> - tokens_multiple_1(reverse(S), Seps, []) + tokens_multiple_1(lists:reverse(S), Seps, []) end. tokens_single_1([Sep|S], Sep, Toks) -> @@ -342,8 +1911,8 @@ sub_word(String, Index, Char) when is_integer(Index), is_integer(Char) -> s_word(strip(String, left, Char), Index, Char, 1, []) end. -s_word([], _, _, _,Res) -> reverse(Res); -s_word([Char|_],Index,Char,Index,Res) -> reverse(Res); +s_word([], _, _, _,Res) -> lists:reverse(Res); +s_word([Char|_],Index,Char,Index,Res) -> lists:reverse(Res); s_word([H|T],Index,Char,Index,Res) -> s_word(T,Index,Char,Index,[H|Res]); s_word([Char|T],Stop,Char,Index,Res) when Index < Stop -> s_word(strip(T,left,Char),Stop,Char,Index+1,Res); @@ -359,7 +1928,7 @@ strip(String) -> strip(String, both). -spec strip(String, Direction) -> Stripped when String :: string(), Stripped :: string(), - Direction :: left | right | both. + Direction :: 'left' | 'right' | 'both'. strip(String, left) -> strip_left(String, $\s); strip(String, right) -> strip_right(String, $\s); @@ -369,7 +1938,7 @@ strip(String, both) -> -spec strip(String, Direction, Character) -> Stripped when String :: string(), Stripped :: string(), - Direction :: left | right | both, + Direction :: 'left' | 'right' | 'both', Character :: char(). strip(String, right, Char) -> strip_right(String, Char); @@ -408,7 +1977,7 @@ left(String, Len) when is_integer(Len) -> left(String, Len, $\s). Character :: char(). left(String, Len, Char) when is_integer(Char) -> - Slen = length(String), + Slen = erlang:length(String), if Slen > Len -> substr(String, 1, Len); Slen < Len -> l_pad(String, Len-Slen, Char); @@ -433,7 +2002,7 @@ right(String, Len) when is_integer(Len) -> right(String, Len, $\s). Character :: char(). right(String, Len, Char) when is_integer(Char) -> - Slen = length(String), + Slen = erlang:length(String), if Slen > Len -> substr(String, Slen-Len+1); Slen < Len -> r_pad(String, Len-Slen, Char); @@ -460,7 +2029,7 @@ centre(String, Len) when is_integer(Len) -> centre(String, Len, $\s). centre(String, 0, Char) when is_list(String), is_integer(Char) -> []; % Strange cases to centre string centre(String, Len, Char) when is_integer(Char) -> - Slen = length(String), + Slen = erlang:length(String), if Slen > Len -> substr(String, (Slen-Len) div 2 + 1, Len); Slen < Len -> diff --git a/lib/stdlib/src/supervisor.erl b/lib/stdlib/src/supervisor.erl index 3c77501c0f..7920e55930 100644 --- a/lib/stdlib/src/supervisor.erl +++ b/lib/stdlib/src/supervisor.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2014. All Rights Reserved. +%% Copyright Ericsson AB 1996-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -30,9 +30,12 @@ %% Internal exports -export([init/1, handle_call/3, handle_cast/2, handle_info/2, - terminate/2, code_change/3]). + terminate/2, code_change/3, format_status/2]). -export([try_again_restart/2]). +%% For release_handler only +-export([get_callback_module/1]). + %%-------------------------------------------------------------------------- -export_type([sup_flags/0, child_spec/0, startchild_ret/0, strategy/0]). @@ -54,8 +57,8 @@ | {'global', Name :: atom()} | {'via', Module :: module(), Name :: any()} | pid(). --type child_spec() :: #{id => child_id(), % mandatory - start => mfargs(), % mandatory +-type child_spec() :: #{id := child_id(), % mandatory + start := mfargs(), % mandatory restart => restart(), % optional shutdown => shutdown(), % optional type => worker(), % optional @@ -107,12 +110,15 @@ -define(SET, sets:set). -record(state, {name, - strategy :: strategy(), + strategy :: strategy() | 'undefined', children = [] :: [child_rec()], - dynamics :: ?DICT(pid(), list()) | ?SET(pid()), - intensity :: non_neg_integer(), - period :: pos_integer(), + dynamics :: {'dict', ?DICT(pid(), list())} + | {'set', ?SET(pid())} + | 'undefined', + intensity :: non_neg_integer() | 'undefined', + period :: pos_integer() | 'undefined', restarts = [], + dynamic_restarts = 0 :: non_neg_integer(), module, args}). -type state() :: #state{}. @@ -240,7 +246,7 @@ check_childspecs(ChildSpecs) when is_list(ChildSpecs) -> check_childspecs(X) -> {error, {badarg, X}}. %%%----------------------------------------------------------------- -%%% Called by timer:apply_after from restart/2 +%%% Called by restart/2 -spec try_again_restart(SupRef, Child) -> ok when SupRef :: sup_ref(), Child :: child_id() | pid(). @@ -250,6 +256,22 @@ try_again_restart(Supervisor, Child) -> cast(Supervisor, Req) -> gen_server:cast(Supervisor, Req). +%%%----------------------------------------------------------------- +%%% Called by release_handler during upgrade +-spec get_callback_module(Pid) -> Module when + Pid :: pid(), + Module :: atom(). +get_callback_module(Pid) -> + {status, _Pid, {module, _Mod}, + [_PDict, _SysState, _Parent, _Dbg, Misc]} = sys:get_status(Pid), + case lists:keyfind(supervisor, 1, Misc) of + {supervisor, [{"Callback", Mod}]} -> + Mod; + _ -> + [_Header, _Data, {data, [{"State", State}]} | _] = Misc, + State#state.module + end. + %%% --------------------------------------------------- %%% %%% Initialize the supervisor. @@ -504,39 +526,26 @@ handle_call(which_children, _From, State) -> handle_call(count_children, _From, #state{children = [#child{restart_type = temporary, child_type = CT}]} = State) when ?is_simple(State) -> - {Active, Count} = - ?SETS:fold(fun(Pid, {Alive, Tot}) -> - case is_pid(Pid) andalso is_process_alive(Pid) of - true ->{Alive+1, Tot +1}; - false -> - {Alive, Tot + 1} - end - end, {0, 0}, dynamics_db(temporary, State#state.dynamics)), + Sz = ?SETS:size(dynamics_db(temporary, State#state.dynamics)), Reply = case CT of - supervisor -> [{specs, 1}, {active, Active}, - {supervisors, Count}, {workers, 0}]; - worker -> [{specs, 1}, {active, Active}, - {supervisors, 0}, {workers, Count}] + supervisor -> [{specs, 1}, {active, Sz}, + {supervisors, Sz}, {workers, 0}]; + worker -> [{specs, 1}, {active, Sz}, + {supervisors, 0}, {workers, Sz}] end, {reply, Reply, State}; -handle_call(count_children, _From, #state{children = [#child{restart_type = RType, +handle_call(count_children, _From, #state{dynamic_restarts = Restarts, + children = [#child{restart_type = RType, child_type = CT}]} = State) when ?is_simple(State) -> - {Active, Count} = - ?DICTS:fold(fun(Pid, _Val, {Alive, Tot}) -> - case is_pid(Pid) andalso is_process_alive(Pid) of - true -> - {Alive+1, Tot +1}; - false -> - {Alive, Tot + 1} - end - end, {0, 0}, dynamics_db(RType, State#state.dynamics)), + Sz = ?DICTS:size(dynamics_db(RType, State#state.dynamics)), + Active = Sz - Restarts, Reply = case CT of supervisor -> [{specs, 1}, {active, Active}, - {supervisors, Count}, {workers, 0}]; + {supervisors, Sz}, {workers, 0}]; worker -> [{specs, 1}, {active, Active}, - {supervisors, 0}, {workers, Count}] + {supervisors, 0}, {workers, Sz}] end, {reply, Reply, State}; @@ -567,8 +576,8 @@ count_child(#child{pid = Pid, child_type = supervisor}, end. -%%% If a restart attempt failed, this message is sent via -%%% timer:apply_after(0,...) in order to give gen_server the chance to +%%% If a restart attempt failed, this message is cast +%%% from restart/2 in order to give gen_server the chance to %%% check it's inbox before trying again. -spec handle_cast({try_again_restart, child_id() | pid()}, state()) -> {'noreply', state()} | {stop, shutdown, state()}. @@ -577,7 +586,7 @@ handle_cast({try_again_restart,Pid}, #state{children=[Child]}=State) when ?is_simple(State) -> RT = Child#child.restart_type, RPid = restarting(Pid), - case dynamic_child_args(RPid, dynamics_db(RT, State#state.dynamics)) of + case dynamic_child_args(RPid, RT, State#state.dynamics) of {ok, Args} -> {M, F, _} = Child#child.mfargs, NChild = Child#child{pid = RPid, mfargs = {M, F, Args}}, @@ -619,7 +628,7 @@ handle_info({'EXIT', Pid, Reason}, State) -> end; handle_info(Msg, State) -> - error_logger:error_msg("Supervisor received unexpected message: ~p~n", + error_logger:error_msg("Supervisor received unexpected message: ~tp~n", [Msg]), {noreply, State}. @@ -735,7 +744,7 @@ handle_start_child(Child, State) -> restart_child(Pid, Reason, #state{children = [Child]} = State) when ?is_simple(State) -> RestartType = Child#child.restart_type, - case dynamic_child_args(Pid, dynamics_db(RestartType, State#state.dynamics)) of + case dynamic_child_args(Pid, RestartType, State#state.dynamics) of {ok, Args} -> {M, F, _} = Child#child.mfargs, NChild = Child#child{pid = Pid, mfargs = {M, F, Args}}, @@ -786,16 +795,10 @@ restart(Child, State) -> Id = if ?is_simple(State) -> Child#child.pid; true -> Child#child.name end, - {ok, _TRef} = timer:apply_after(0, - ?MODULE, - try_again_restart, - [self(),Id]), + ok = try_again_restart(self(), Id), {ok,NState2}; {try_again, NState2, #child{name=ChName}} -> - {ok, _TRef} = timer:apply_after(0, - ?MODULE, - try_again_restart, - [self(),ChName]), + ok = try_again_restart(self(), ChName), {ok,NState2}; Other -> Other @@ -806,20 +809,31 @@ restart(Child, State) -> {shutdown, remove_child(Child, NState)} end. -restart(simple_one_for_one, Child, State) -> +restart(simple_one_for_one, Child, State0) -> #child{pid = OldPid, mfargs = {M, F, A}} = Child, + State = case OldPid of + ?restarting(_) -> + NRes = State0#state.dynamic_restarts - 1, + State0#state{dynamic_restarts = NRes}; + _ -> + State0 + end, Dynamics = ?DICTS:erase(OldPid, dynamics_db(Child#child.restart_type, State#state.dynamics)), case do_start_child_i(M, F, A) of {ok, Pid} -> - NState = State#state{dynamics = ?DICTS:store(Pid, A, Dynamics)}, + DynamicsDb = {dict, ?DICTS:store(Pid, A, Dynamics)}, + NState = State#state{dynamics = DynamicsDb}, {ok, NState}; {ok, Pid, _Extra} -> - NState = State#state{dynamics = ?DICTS:store(Pid, A, Dynamics)}, + DynamicsDb = {dict, ?DICTS:store(Pid, A, Dynamics)}, + NState = State#state{dynamics = DynamicsDb}, {ok, NState}; {error, Error} -> - NState = State#state{dynamics = ?DICTS:store(restarting(OldPid), A, - Dynamics)}, + NRestarts = State#state.dynamic_restarts + 1, + DynamicsDb = {dict, ?DICTS:store(restarting(OldPid), A, Dynamics)}, + NState = State#state{dynamic_restarts = NRestarts, + dynamics = DynamicsDb}, report_error(start_error, Error, Child, State#state.name), {try_again, NState} end; @@ -1073,6 +1087,10 @@ wait_dynamic_children(#child{restart_type=RType} = Child, Pids, Sz, wait_dynamic_children(Child, ?SETS:del_element(Pid, Pids), Sz-1, TRef, EStack); + {'DOWN', _MRef, process, Pid, {shutdown, _}} -> + wait_dynamic_children(Child, ?SETS:del_element(Pid, Pids), Sz-1, + TRef, EStack); + {'DOWN', _MRef, process, Pid, normal} when RType =/= permanent -> wait_dynamic_children(Child, ?SETS:del_element(Pid, Pids), Sz-1, TRef, EStack); @@ -1083,7 +1101,7 @@ wait_dynamic_children(#child{restart_type=RType} = Child, Pids, Sz, {timeout, TRef, kill} -> ?SETS:fold(fun(P, _) -> exit(P, kill) end, ok, Pids), - wait_dynamic_children(Child, Pids, Sz-1, undefined, EStack) + wait_dynamic_children(Child, Pids, Sz, undefined, EStack) end. %%----------------------------------------------------------------- @@ -1102,31 +1120,32 @@ save_child(Child, #state{children = Children} = State) -> State#state{children = [Child |Children]}. save_dynamic_child(temporary, Pid, _, #state{dynamics = Dynamics} = State) -> - State#state{dynamics = ?SETS:add_element(Pid, dynamics_db(temporary, Dynamics))}; + DynamicsDb = dynamics_db(temporary, Dynamics), + State#state{dynamics = {set, ?SETS:add_element(Pid, DynamicsDb)}}; save_dynamic_child(RestartType, Pid, Args, #state{dynamics = Dynamics} = State) -> - State#state{dynamics = ?DICTS:store(Pid, Args, dynamics_db(RestartType, Dynamics))}. + DynamicsDb = dynamics_db(RestartType, Dynamics), + State#state{dynamics = {dict, ?DICTS:store(Pid, Args, DynamicsDb)}}. dynamics_db(temporary, undefined) -> ?SETS:new(); dynamics_db(_, undefined) -> ?DICTS:new(); -dynamics_db(_,Dynamics) -> - Dynamics. - -dynamic_child_args(Pid, Dynamics) -> - case ?SETS:is_set(Dynamics) of - true -> - {ok, undefined}; - false -> - ?DICTS:find(Pid, Dynamics) - end. +dynamics_db(_, {_Tag, DynamicsDb}) -> + DynamicsDb. + +dynamic_child_args(_Pid, temporary, _DynamicsDb) -> + {ok, undefined}; +dynamic_child_args(Pid, _RT, {dict, DynamicsDb}) -> + ?DICTS:find(Pid, DynamicsDb); +dynamic_child_args(_Pid, _RT, undefined) -> + error. state_del_child(#child{pid = Pid, restart_type = temporary}, State) when ?is_simple(State) -> NDynamics = ?SETS:del_element(Pid, dynamics_db(temporary, State#state.dynamics)), - State#state{dynamics = NDynamics}; + State#state{dynamics = {set, NDynamics}}; state_del_child(#child{pid = Pid, restart_type = RType}, State) when ?is_simple(State) -> NDynamics = ?DICTS:erase(Pid, dynamics_db(RType, State#state.dynamics)), - State#state{dynamics = NDynamics}; + State#state{dynamics = {dict, NDynamics}}; state_del_child(Child, State) -> NChildren = del_child(Child#child.name, State#state.children), State#state{children = NChildren}. @@ -1160,19 +1179,19 @@ split_child(_, [], After) -> get_child(Name, State) -> get_child(Name, State, false). + get_child(Pid, State, AllowPid) when AllowPid, is_pid(Pid) -> get_dynamic_child(Pid, State); get_child(Name, State, _) -> lists:keysearch(Name, #child.name, State#state.children). get_dynamic_child(Pid, #state{children=[Child], dynamics=Dynamics}) -> - DynamicsDb = dynamics_db(Child#child.restart_type, Dynamics), - case is_dynamic_pid(Pid, DynamicsDb) of + case is_dynamic_pid(Pid, Dynamics) of true -> {value, Child#child{pid=Pid}}; false -> RPid = restarting(Pid), - case is_dynamic_pid(RPid, DynamicsDb) of + case is_dynamic_pid(RPid, Dynamics) of true -> {value, Child#child{pid=RPid}}; false -> @@ -1183,13 +1202,12 @@ get_dynamic_child(Pid, #state{children=[Child], dynamics=Dynamics}) -> end end. -is_dynamic_pid(Pid, Dynamics) -> - case ?SETS:is_set(Dynamics) of - true -> - ?SETS:is_element(Pid, Dynamics); - false -> - ?DICTS:is_key(Pid, Dynamics) - end. +is_dynamic_pid(Pid, {dict, Dynamics}) -> + ?DICTS:is_key(Pid, Dynamics); +is_dynamic_pid(Pid, {set, Dynamics}) -> + ?SETS:is_element(Pid, Dynamics); +is_dynamic_pid(_Pid, undefined) -> + false. replace_child(Child, State) -> Chs = do_replace_child(Child, State#state.children), @@ -1441,3 +1459,9 @@ report_progress(Child, SupName) -> Progress = [{supervisor, SupName}, {started, extract_child(Child)}], error_logger:info_report(progress, Progress). + +format_status(terminate, [_PDict, State]) -> + State; +format_status(_, [_PDict, State]) -> + [{data, [{"State", State}]}, + {supervisor, [{"Callback", State#state.module}]}]. diff --git a/lib/stdlib/src/supervisor_bridge.erl b/lib/stdlib/src/supervisor_bridge.erl index 18218b71ad..af1e046d30 100644 --- a/lib/stdlib/src/supervisor_bridge.erl +++ b/lib/stdlib/src/supervisor_bridge.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2011. All Rights Reserved. +%% Copyright Ericsson AB 1996-2016. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. diff --git a/lib/stdlib/src/sys.erl b/lib/stdlib/src/sys.erl index a7debb00f5..0c578acf21 100644 --- a/lib/stdlib/src/sys.erl +++ b/lib/stdlib/src/sys.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2014. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -38,7 +38,9 @@ -export_type([dbg_opt/0]). --type name() :: pid() | atom() | {'global', atom()}. +-type name() :: pid() | atom() + | {'global', term()} + | {'via', module(), term()}. -type system_event() :: {'in', Msg :: _} | {'in', Msg :: _, From :: _} | {'out', Msg :: _, To :: _} @@ -525,7 +527,7 @@ debug_cmd({log_to_file, false}, Debug) -> {ok, NDebug}; debug_cmd({log_to_file, FileName}, Debug) -> NDebug = close_log_file(Debug), - case file:open(FileName, [write]) of + case file:open(FileName, [write,{encoding,utf8}]) of {ok, Fd} -> {ok, install_debug(log_to_file, Fd, NDebug)}; _Error -> @@ -648,7 +650,7 @@ debug_options([{log, N} | T], Debug) when is_integer(N), N > 0 -> debug_options([statistics | T], Debug) -> debug_options(T, install_debug(statistics, init_stat(), Debug)); debug_options([{log_to_file, FileName} | T], Debug) -> - case file:open(FileName, [write]) of + case file:open(FileName, [write,{encoding,utf8}]) of {ok, Fd} -> debug_options(T, install_debug(log_to_file, Fd, Debug)); _Error -> diff --git a/lib/stdlib/src/timer.erl b/lib/stdlib/src/timer.erl index f7530447bb..df10790ea0 100644 --- a/lib/stdlib/src/timer.erl +++ b/lib/stdlib/src/timer.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2013. All Rights Reserved. +%% Copyright Ericsson AB 1996-2016. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -165,7 +165,7 @@ tc(F) -> T1 = erlang:monotonic_time(), Val = F(), T2 = erlang:monotonic_time(), - Time = erlang:convert_time_unit(T2 - T1, native, micro_seconds), + Time = erlang:convert_time_unit(T2 - T1, native, microsecond), {Time, Val}. %% @@ -180,7 +180,7 @@ tc(F, A) -> T1 = erlang:monotonic_time(), Val = apply(F, A), T2 = erlang:monotonic_time(), - Time = erlang:convert_time_unit(T2 - T1, native, micro_seconds), + Time = erlang:convert_time_unit(T2 - T1, native, microsecond), {Time, Val}. %% @@ -196,7 +196,7 @@ tc(M, F, A) -> T1 = erlang:monotonic_time(), Val = apply(M, F, A), T2 = erlang:monotonic_time(), - Time = erlang:convert_time_unit(T2 - T1, native, micro_seconds), + Time = erlang:convert_time_unit(T2 - T1, native, microsecond), {Time, Val}. %% diff --git a/lib/stdlib/src/unicode.erl b/lib/stdlib/src/unicode.erl index 3e8e6f5101..fbe8a94074 100644 --- a/lib/stdlib/src/unicode.erl +++ b/lib/stdlib/src/unicode.erl @@ -1,8 +1,8 @@ %% %% %CopyrightBegin% -%% -%% Copyright Ericsson AB 2008-2013. All Rights Reserved. -%% +%% +%% Copyright Ericsson AB 2008-2017. All Rights Reserved. +%% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. %% You may obtain a copy of the License at @@ -14,7 +14,7 @@ %% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. %% See the License for the specific language governing permissions and %% limitations under the License. -%% +%% %% %CopyrightEnd% %% -module(unicode). @@ -22,7 +22,12 @@ -export([characters_to_list/1, characters_to_list_int/2, characters_to_binary/1, characters_to_binary_int/2, characters_to_binary/3, - bom_to_encoding/1, encoding_to_bom/1]). + bom_to_encoding/1, encoding_to_bom/1, + characters_to_nfd_list/1, characters_to_nfd_binary/1, + characters_to_nfc_list/1, characters_to_nfc_binary/1, + characters_to_nfkd_list/1, characters_to_nfkd_binary/1, + characters_to_nfkc_list/1, characters_to_nfkc_binary/1 + ]). -export_type([chardata/0, charlist/0, encoding/0, external_chardata/0, external_charlist/0, latin1_char/0, latin1_chardata/0, @@ -102,35 +107,6 @@ characters_to_list(_, _) -> characters_to_list(ML) -> unicode:characters_to_list(ML,unicode). -characters_to_list_int(ML, Encoding) -> - try - do_characters_to_list(ML,Encoding) - catch - error:AnyError -> - TheError = case AnyError of - system_limit -> - system_limit; - _ -> - badarg - end, - {'EXIT',{new_stacktrace,[{Mod,_,L,_}|Rest]}} = - (catch erlang:error(new_stacktrace, - [ML,Encoding])), - erlang:raise(error,TheError,[{Mod,characters_to_list,L}|Rest]) - end. - -% XXX: Optimize me! -do_characters_to_list(ML, Encoding) -> - case unicode:characters_to_binary(ML,Encoding) of - Bin when is_binary(Bin) -> - unicode:characters_to_list(Bin,utf8); - {error,Encoded,Rest} -> - {error,unicode:characters_to_list(Encoded,utf8),Rest}; - {incomplete, Encoded2, Rest2} -> - {incomplete,unicode:characters_to_list(Encoded2,utf8),Rest2} - end. - - -spec characters_to_binary(Data) -> Result when Data :: latin1_chardata() | chardata() | external_chardata(), Result :: binary() @@ -154,24 +130,6 @@ characters_to_binary(ML) -> [ML])), erlang:raise(error,TheError,[{Mod,characters_to_binary,L}|Rest]) end. - - -characters_to_binary_int(ML,InEncoding) -> - try - characters_to_binary_int(ML,InEncoding,unicode) - catch - error:AnyError -> - TheError = case AnyError of - system_limit -> - system_limit; - _ -> - badarg - end, - {'EXIT',{new_stacktrace,[{Mod,_,L,_}|Rest]}} = - (catch erlang:error(new_stacktrace, - [ML,InEncoding])), - erlang:raise(error,TheError,[{Mod,characters_to_binary,L}|Rest]) - end. -spec characters_to_binary(Data, InEncoding, OutEncoding) -> Result when Data :: latin1_chardata() | chardata() | external_chardata(), @@ -192,7 +150,7 @@ characters_to_binary(ML, latin1, Uni) when is_binary(ML) and ((Uni =:= utf8) or try characters_to_binary_int(ML,latin1,utf8) catch - error:AnyError -> + error:AnyError -> TheError = case AnyError of system_limit -> system_limit; @@ -228,7 +186,7 @@ characters_to_binary(ML,Uni,latin1) when is_binary(ML) and ((Uni =:= utf8) or [{Mod,characters_to_binary,L}|Rest]) end end; - + characters_to_binary(ML, InEncoding, OutEncoding) -> try characters_to_binary_int(ML,InEncoding,OutEncoding) @@ -246,53 +204,6 @@ characters_to_binary(ML, InEncoding, OutEncoding) -> erlang:raise(error,TheError,[{Mod,characters_to_binary,L}|Rest]) end. -characters_to_binary_int(ML, InEncoding, OutEncoding) when - InEncoding =:= latin1, OutEncoding =:= unicode; - InEncoding =:= latin1, OutEncoding =:= utf8; - InEncoding =:= unicode, OutEncoding =:= unicode; - InEncoding =:= unicode, OutEncoding =:= utf8; - InEncoding =:= utf8, OutEncoding =:= unicode; - InEncoding =:= utf8, OutEncoding =:= utf8 -> - unicode:characters_to_binary(ML,InEncoding); - -characters_to_binary_int(ML, InEncoding, OutEncoding) -> - {InTrans,Limit} = case OutEncoding of - latin1 -> {i_trans_chk(InEncoding),255}; - _ -> {i_trans(InEncoding),case InEncoding of latin1 -> 255; _ -> 16#10FFFF end} - end, - OutTrans = o_trans(OutEncoding), - Res = - ml_map(ML, - fun(Part,Accum) when is_binary(Part) -> - case InTrans(Part) of - List when is_list(List) -> - Tail = OutTrans(List), - <<Accum/binary, Tail/binary>>; - {error, Translated, Rest} -> - Tail = OutTrans(Translated), - {error, <<Accum/binary,Tail/binary>>, Rest}; - {incomplete, Translated, Rest, Missing} -> - Tail = OutTrans(Translated), - {incomplete, <<Accum/binary,Tail/binary>>, Rest, - Missing} - end; - (Part, Accum) when is_integer(Part), Part =< Limit -> - case OutTrans([Part]) of - Binary when is_binary(Binary) -> - <<Accum/binary, Binary/binary>>; - {error, _, [Part]} -> - {error,Accum,[Part]} - end; - (Part, Accum) -> - {error, Accum, [Part]} - end,<<>>), - case Res of - {incomplete,A,B,_} -> - {incomplete,A,B}; - _ -> - Res - end. - -spec bom_to_encoding(Bin) -> {Encoding, Length} when Bin :: binary(), Encoding :: 'latin1' | 'utf8' @@ -335,11 +246,215 @@ encoding_to_bom({utf32,little}) -> <<255,254,0,0>>; encoding_to_bom(latin1) -> <<>>. - -cbv(utf8,<<1:1,1:1,0:1,_:5>>) -> +-define(GC_N, 200). %% arbitrary number + +%% Canonical decompose string to list of chars +-spec characters_to_nfd_list(chardata()) -> [char()] | {error, [char()], chardata()}. +characters_to_nfd_list(CD) -> + characters_to_nfd_list(CD, []). +characters_to_nfd_list(CD, Acc) -> + case unicode_util:nfd(CD) of + [GC|Str] when is_list(GC) -> characters_to_nfd_list(Str, lists:reverse(GC, Acc)); + [CP|Str] -> characters_to_nfd_list(Str, [CP | Acc]); + [] -> lists:reverse(Acc); + {error,Error} -> {error, lists:reverse(Acc), Error} + end. + +-spec characters_to_nfd_binary(chardata()) -> unicode_binary() | {error, unicode_binary(), chardata()}. +characters_to_nfd_binary(CD) -> + characters_to_nfd_binary(CD, ?GC_N, [], []). + +characters_to_nfd_binary(CD, N, Row, Acc) when N > 0 -> + case unicode_util:nfd(CD) of + [GC|Str] -> characters_to_nfd_binary(Str, N-1, [GC|Row], Acc); + [] -> acc_to_binary(prepend_row_to_acc(Row, Acc)); + {error, Error} -> {error, acc_to_binary(prepend_row_to_acc(Row, Acc)), Error} + end; +characters_to_nfd_binary(CD, _, Row, Acc) -> + characters_to_nfd_binary(CD, ?GC_N, [], prepend_row_to_acc(Row, Acc)). + +%% Compability Canonical decompose string to list of chars. +-spec characters_to_nfkd_list(chardata()) -> [char()] | {error, [char()], chardata()}. +characters_to_nfkd_list(CD) -> + characters_to_nfkd_list(CD, []). +characters_to_nfkd_list(CD, Acc) -> + case unicode_util:nfkd(CD) of + [GC|Str] when is_list(GC) -> characters_to_nfkd_list(Str, lists:reverse(GC, Acc)); + [CP|Str] -> characters_to_nfkd_list(Str, [CP | Acc]); + [] -> lists:reverse(Acc); + {error,Error} -> {error, lists:reverse(Acc), Error} + end. + +-spec characters_to_nfkd_binary(chardata()) -> unicode_binary() | {error, unicode_binary(), chardata()}. +characters_to_nfkd_binary(CD) -> + characters_to_nfkd_binary(CD, ?GC_N, [], []). + +characters_to_nfkd_binary(CD, N, Row, Acc) when N > 0 -> + case unicode_util:nfkd(CD) of + [GC|Str] -> characters_to_nfkd_binary(Str, N-1, [GC|Row], Acc); + [] -> acc_to_binary(prepend_row_to_acc(Row, Acc)); + {error, Error} -> {error, acc_to_binary(prepend_row_to_acc(Row, Acc)), Error} + end; +characters_to_nfkd_binary(CD, _, Row, Acc) -> + characters_to_nfkd_binary(CD, ?GC_N, [], prepend_row_to_acc(Row, Acc)). + + +%% Canonical compose string to list of chars +-spec characters_to_nfc_list(chardata()) -> [char()] | {error, [char()], chardata()}. +characters_to_nfc_list(CD) -> + characters_to_nfc_list(CD, []). +characters_to_nfc_list(CD, Acc) -> + case unicode_util:nfc(CD) of + [GC|Str] when is_list(GC) -> characters_to_nfc_list(Str, lists:reverse(GC, Acc)); + [CP|Str] -> characters_to_nfc_list(Str, [CP | Acc]); + [] -> lists:reverse(Acc); + {error,Error} -> {error, lists:reverse(Acc), Error} + end. + +-spec characters_to_nfc_binary(chardata()) -> unicode_binary() | {error, unicode_binary(), chardata()}. +characters_to_nfc_binary(CD) -> + characters_to_nfc_binary(CD, ?GC_N, [], []). + +characters_to_nfc_binary(CD, N, Row, Acc) when N > 0 -> + case unicode_util:nfc(CD) of + [GC|Str] -> characters_to_nfc_binary(Str, N-1, [GC|Row], Acc); + [] -> acc_to_binary(prepend_row_to_acc(Row, Acc)); + {error, Error} -> {error, acc_to_binary(prepend_row_to_acc(Row, Acc)), Error} + end; +characters_to_nfc_binary(CD, _, Row, Acc) -> + characters_to_nfc_binary(CD, ?GC_N, [], prepend_row_to_acc(Row, Acc)). + +%% Compability Canonical compose string to list of chars +-spec characters_to_nfkc_list(chardata()) -> [char()] | {error, [char()], chardata()}. +characters_to_nfkc_list(CD) -> + characters_to_nfkc_list(CD, []). +characters_to_nfkc_list(CD, Acc) -> + case unicode_util:nfkc(CD) of + [GC|Str] when is_list(GC) -> characters_to_nfkc_list(Str, lists:reverse(GC, Acc)); + [CP|Str] -> characters_to_nfkc_list(Str, [CP | Acc]); + [] -> lists:reverse(Acc); + {error,Error} -> {error, lists:reverse(Acc), Error} + end. + +-spec characters_to_nfkc_binary(chardata()) -> unicode_binary() | {error, unicode_binary(), chardata()}. +characters_to_nfkc_binary(CD) -> + characters_to_nfkc_binary(CD, ?GC_N, [], []). + +characters_to_nfkc_binary(CD, N, Row, Acc) when N > 0 -> + case unicode_util:nfkc(CD) of + [GC|Str] -> characters_to_nfkc_binary(Str, N-1, [GC|Row], Acc); + [] -> acc_to_binary(prepend_row_to_acc(Row, Acc)); + {error, Error} -> {error, acc_to_binary(prepend_row_to_acc(Row, Acc)), Error} + end; +characters_to_nfkc_binary(CD, _, Row, Acc) -> + characters_to_nfkc_binary(CD, ?GC_N, [], prepend_row_to_acc(Row, Acc)). + +acc_to_binary(Acc) -> + list_to_binary(lists:reverse(Acc)). +prepend_row_to_acc(Row, Acc) -> + [characters_to_binary(lists:reverse(Row))|Acc]. + +%% internals + +characters_to_list_int(ML, Encoding) -> + try + do_characters_to_list(ML,Encoding) + catch + error:AnyError -> + TheError = case AnyError of + system_limit -> + system_limit; + _ -> + badarg + end, + {'EXIT',{new_stacktrace,[{Mod,_,L,_}|Rest]}} = + (catch erlang:error(new_stacktrace, + [ML,Encoding])), + erlang:raise(error,TheError,[{Mod,characters_to_list,L}|Rest]) + end. + + % XXX: Optimize me! +do_characters_to_list(ML, Encoding) -> + case unicode:characters_to_binary(ML,Encoding) of + Bin when is_binary(Bin) -> + unicode:characters_to_list(Bin,utf8); + {error,Encoded,Rest} -> + {error,unicode:characters_to_list(Encoded,utf8),Rest}; + {incomplete, Encoded2, Rest2} -> + {incomplete,unicode:characters_to_list(Encoded2,utf8),Rest2} + end. + + +characters_to_binary_int(ML,InEncoding) -> + try + characters_to_binary_int(ML,InEncoding,unicode) + catch + error:AnyError -> + TheError = case AnyError of + system_limit -> + system_limit; + _ -> + badarg + end, + {'EXIT',{new_stacktrace,[{Mod,_,L,_}|Rest]}} = + (catch erlang:error(new_stacktrace, + [ML,InEncoding])), + erlang:raise(error,TheError,[{Mod,characters_to_binary,L}|Rest]) + end. + + +characters_to_binary_int(ML, InEncoding, OutEncoding) when + InEncoding =:= latin1, OutEncoding =:= unicode; + InEncoding =:= latin1, OutEncoding =:= utf8; + InEncoding =:= unicode, OutEncoding =:= unicode; + InEncoding =:= unicode, OutEncoding =:= utf8; + InEncoding =:= utf8, OutEncoding =:= unicode; + InEncoding =:= utf8, OutEncoding =:= utf8 -> + unicode:characters_to_binary(ML,InEncoding); + +characters_to_binary_int(ML, InEncoding, OutEncoding) -> + {InTrans,Limit} = case OutEncoding of + latin1 -> {i_trans_chk(InEncoding),255}; + _ -> {i_trans(InEncoding),case InEncoding of latin1 -> 255; _ -> 16#10FFFF end} + end, + OutTrans = o_trans(OutEncoding), + Res = + ml_map(ML, + fun(Part,Accum) when is_binary(Part) -> + case InTrans(Part) of + List when is_list(List) -> + Tail = OutTrans(List), + <<Accum/binary, Tail/binary>>; + {error, Translated, Rest} -> + Tail = OutTrans(Translated), + {error, <<Accum/binary,Tail/binary>>, Rest}; + {incomplete, Translated, Rest, Missing} -> + Tail = OutTrans(Translated), + {incomplete, <<Accum/binary,Tail/binary>>, Rest, + Missing} + end; + (Part, Accum) when is_integer(Part), Part =< Limit -> + case OutTrans([Part]) of + Binary when is_binary(Binary) -> + <<Accum/binary, Binary/binary>>; + {error, _, [Part]} -> + {error,Accum,[Part]} + end; + (Part, Accum) -> + {error, Accum, [Part]} + end,<<>>), + case Res of + {incomplete,A,B,_} -> + {incomplete,A,B}; + _ -> + Res + end. + + +cbv(utf8,<<1:1,1:1,0:1,_:5>>) -> 1; -cbv(utf8,<<1:1,1:1,1:1,0:1,_:4,R/binary>>) -> +cbv(utf8,<<1:1,1:1,1:1,0:1,_:4,R/binary>>) -> case R of <<>> -> 2; @@ -386,18 +501,18 @@ cbv({utf32,big}, <<0:8>>) -> 3; cbv({utf32,big}, <<0:8,X:8>>) when X =< 16 -> 2; -cbv({utf32,big}, <<0:8,X:8,Y:8>>) +cbv({utf32,big}, <<0:8,X:8,Y:8>>) when X =< 16, ((X > 0) or ((Y =< 215) or (Y >= 224))) -> 1; cbv({utf32,big},_) -> false; cbv({utf32,little},<<_:8>>) -> 3; -cbv({utf32,little},<<_:8,_:8>>) -> +cbv({utf32,little},<<_:8,_:8>>) -> 2; cbv({utf32,little},<<X:8,255:8,0:8>>) when X =:= 254; X =:= 255 -> false; -cbv({utf32,little},<<_:8,Y:8,X:8>>) +cbv({utf32,little},<<_:8,Y:8,X:8>>) when X =< 16, ((X > 0) or ((Y =< 215) or (Y >= 224))) -> 1; cbv({utf32,little},_) -> @@ -417,8 +532,8 @@ ml_map([Part|T],Fun,Accum) when is_integer(Part) -> Bin2 when is_binary(Bin2) -> Bin2; {error, Converted, Rest} -> - {error, Converted, Rest}; - {incomplete, Converted, Rest,X} -> + {error, Converted, Rest}; + {incomplete, Converted, Rest,X} -> {incomplete, Converted, Rest,X} end; % Can not be incomplete - it's an integer @@ -471,7 +586,7 @@ ml_map(Part,Fun,Accum) when is_binary(Part), byte_size(Part) > 8192 -> ml_map(Bin,Fun,Accum) when is_binary(Bin) -> Fun(Bin,Accum). - + @@ -523,7 +638,7 @@ o_trans(utf8) -> <<One/utf8>> end, L) end; - + o_trans(utf16) -> fun(L) -> do_o_binary(fun(One) -> @@ -561,6 +676,8 @@ do_o_binary(F,L) -> erlang:iolist_to_binary(List) end. +-dialyzer({no_improper_lists, do_o_binary2/2}). + do_o_binary2(_F,[]) -> <<>>; do_o_binary2(F,[H|T]) -> @@ -575,9 +692,9 @@ do_o_binary2(F,[H|T]) -> [Bin|Bin3] end end. - + %% Specific functions only allowing codepoints in latin1 range - + do_i_utf8_chk(<<>>) -> []; do_i_utf8_chk(<<U/utf8,R/binary>>) when U =< 255 -> diff --git a/lib/stdlib/src/win32reg.erl b/lib/stdlib/src/win32reg.erl index 8074b2efda..8e82a79cbf 100644 --- a/lib/stdlib/src/win32reg.erl +++ b/lib/stdlib/src/win32reg.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1997-2012. All Rights Reserved. +%% Copyright Ericsson AB 1997-2016. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. diff --git a/lib/stdlib/src/zip.erl b/lib/stdlib/src/zip.erl index d6031dabbc..81f927f399 100644 --- a/lib/stdlib/src/zip.erl +++ b/lib/stdlib/src/zip.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2006-2013. All Rights Reserved. +%% Copyright Ericsson AB 2006-2017. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -179,19 +179,6 @@ 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)). @@ -279,7 +266,8 @@ do_openzip_get(F, #openzip{files = Files, in = In0, input = Input, case file_name_search(F, Files) of {#zip_file{offset = Offset},_}=ZFile -> In1 = Input({seek, bof, Offset}, In0), - case get_z_file(In1, Z, Input, Output, [], fun silent/1, CWD, ZFile) of + case get_z_file(In1, Z, Input, Output, [], fun silent/1, + CWD, ZFile, fun all/1) of {file, R, _In2} -> {ok, R}; _ -> throw(file_not_found) end; @@ -380,9 +368,12 @@ do_unzip(F, Options) -> {Info, In1} = get_central_dir(In0, RawIterator, Input), %% get rid of zip-comment Z = zlib:open(), - Files = get_z_files(Info, Z, In1, Opts, []), - zlib:close(Z), - Input(close, In1), + Files = try + get_z_files(Info, Z, In1, Opts, []) + after + zlib:close(Z), + Input(close, In1) + end, {ok, Files}. %% Iterate over all files in a zip archive @@ -459,11 +450,20 @@ do_zip(F, Files, Options) -> #zip_opts{output = Output, open_opts = OpO} = Opts, Out0 = Output({open, F, OpO}, []), Z = zlib:open(), - {Out1, LHS, Pos} = put_z_files(Files, Z, Out0, 0, Opts, []), - zlib:close(Z), - Out2 = put_central_dir(LHS, Pos, Out1, Opts), - Out3 = Output({close, F}, Out2), - {ok, Out3}. + try + {Out1, LHS, Pos} = put_z_files(Files, Z, Out0, 0, Opts, []), + zlib:close(Z), + Out2 = put_central_dir(LHS, Pos, Out1, Opts), + Out3 = Output({close, F}, Out2), + {ok, Out3} + catch + C:R -> + Stk = erlang:get_stacktrace(), + zlib:close(Z), + Output({close, F}, Out0), + erlang:raise(C, R, Stk) + end. + %% List zip directory contents %% @@ -1378,12 +1378,7 @@ cd_file_header_to_file_info(FileName, 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 +%% Currently, we ignore all the extra fields. add_extra_info(FI, _) -> FI. @@ -1403,9 +1398,10 @@ get_z_files([{#zip_file{offset = Offset},_} = ZFile | Rest], Z, In0, true -> In1 = Input({seek, bof, Offset}, In0), {In2, Acc1} = - case get_z_file(In1, Z, Input, Output, OpO, FB, CWD, ZFile) of + case get_z_file(In1, Z, Input, Output, OpO, FB, + CWD, ZFile, Filter) of {file, GZD, Inx} -> {Inx, [GZD | Acc0]}; - {dir, Inx} -> {Inx, Acc0} + {_, Inx} -> {Inx, Acc0} end, get_z_files(Rest, Z, In2, Opts, Acc1); _ -> @@ -1413,7 +1409,8 @@ get_z_files([{#zip_file{offset = Offset},_} = ZFile | Rest], Z, In0, end. %% get a file from the archive, reading chunks -get_z_file(In0, Z, Input, Output, OpO, FB, CWD, {ZipFile,Extra}) -> +get_z_file(In0, Z, Input, Output, OpO, FB, + CWD, {ZipFile,Extra}, Filter) -> case Input({read, ?LOCAL_FILE_HEADER_SZ}, In0) of {eof, In1} -> {eof, In1}; @@ -1433,29 +1430,64 @@ get_z_file(In0, Z, Input, Output, OpO, FB, CWD, {ZipFile,Extra}) -> end, {BFileN, In3} = Input({read, FileNameLen + ExtraLen}, In1), {FileName, _} = get_file_name_extra(FileNameLen, ExtraLen, BFileN), - FileName1 = add_cwd(CWD, FileName), - case lists:last(FileName) of - $/ -> - %% perhaps this should always be done? - Output({ensure_dir,FileName1},[]), - {dir, In3}; - _ -> - %% FileInfo = local_file_header_to_file_info(LH) - %%{Out, In4, CRC, UncompSize} = - {Out, In4, CRC, _UncompSize} = - get_z_data(CompMethod, In3, FileName1, - CompSize, Input, Output, OpO, Z), - In5 = skip_z_data_descriptor(GPFlag, Input, In4), - %% TODO This should be fixed some day: - %% In5 = Input({set_file_info, FileName, FileInfo#file_info{size=UncompSize}}, In4), - FB(FileName), - CRC =:= CRC32 orelse throw({bad_crc, FileName}), - {file, Out, In5} + ReadAndWrite = + case check_valid_location(CWD, FileName) of + {true,FileName1} -> + true; + {false,FileName1} -> + Filter({ZipFile#zip_file{name = FileName1},Extra}) + end, + case ReadAndWrite of + true -> + case lists:last(FileName) of + $/ -> + %% perhaps this should always be done? + Output({ensure_dir,FileName1},[]), + {dir, In3}; + _ -> + %% FileInfo = local_file_header_to_file_info(LH) + %%{Out, In4, CRC, UncompSize} = + {Out, In4, CRC, _UncompSize} = + get_z_data(CompMethod, In3, FileName1, + CompSize, Input, Output, OpO, Z), + In5 = skip_z_data_descriptor(GPFlag, Input, In4), + %% TODO This should be fixed some day: + %% In5 = Input({set_file_info, FileName, + %% FileInfo#file_info{size=UncompSize}}, In4), + FB(FileName), + CRC =:= CRC32 orelse throw({bad_crc, FileName}), + {file, Out, In5} + end; + false -> + {ignore, In3} end; _ -> throw(bad_local_file_header) end. +%% make sure FileName doesn't have relative path that points over CWD +check_valid_location(CWD, FileName) -> + %% check for directory traversal exploit + case check_dir_level(filename:split(FileName), 0) of + {FileOrDir,Level} when Level < 0 -> + CWD1 = if CWD == "" -> "./"; + true -> CWD + end, + error_logger:format("Illegal path: ~ts, extracting in ~ts~n", + [add_cwd(CWD,FileName),CWD1]), + {false,add_cwd(CWD, FileOrDir)}; + _ -> + {true,add_cwd(CWD, FileName)} + end. + +check_dir_level([FileOrDir], Level) -> + {FileOrDir,Level}; +check_dir_level(["." | Parts], Level) -> + check_dir_level(Parts, Level); +check_dir_level([".." | Parts], Level) -> + check_dir_level(Parts, Level-1); +check_dir_level([_Dir | Parts], Level) -> + check_dir_level(Parts, Level+1). get_file_name_extra(FileNameLen, ExtraLen, B) -> case B of @@ -1534,73 +1566,37 @@ dos_date_time_from_datetime({{Year, Month, Day}, {Hour, Min, Sec}}) -> <<DosDate:16>> = <<YearFrom1980:7, Month:4, Day:5>>, {DosDate, DosTime}. -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). - %% 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). +pwrite_binary(B, Pos, Bin) when byte_size(B) =:= Pos -> + append_bins(Bin, B); +pwrite_binary(B, Pos, Bin) -> + erlang:iolist_to_binary(pwrite_iolist(B, Pos, Bin)). -splitter(Left, Right, 0) -> - {Left, Right}; -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). +append_bins([Bin|Bins], B) when is_binary(Bin) -> + append_bins(Bins, <<B/binary, Bin/binary>>); +append_bins([List|Bins], B) when is_list(List) -> + append_bins(Bins, append_bins(List, B)); +append_bins(Bin, B) when is_binary(Bin) -> + <<B/binary, Bin/binary>>; +append_bins([_|_]=List, B) -> + <<B/binary, (iolist_to_binary(List))/binary>>; +append_bins([], B) -> + B. -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). +-dialyzer({no_improper_lists, pwrite_iolist/3}). -pwrite_iolist(Iolist, Pos, Bin) -> - {Left, Right} = split_iolist(Iolist, Pos), +pwrite_iolist(B, Pos, Bin) -> + {Left, Right} = split_binary(B, Pos), Sz = erlang:iolist_size(Bin), - R = skip_iolist(Right, Sz), + R = skip_bin(Right, Sz), [Left, Bin | R]. -pwrite_binary(B, Pos, Bin) -> - erlang:iolist_to_binary(pwrite_iolist(B, Pos, Bin)). +skip_bin(B, Pos) when is_binary(B) -> + case B of + <<_:Pos/binary, Bin/binary>> -> Bin; + _ -> <<>> + end. %% ZIP header manipulations |