diff options
Diffstat (limited to 'lib/stdlib/src')
87 files changed, 17619 insertions, 7952 deletions
diff --git a/lib/stdlib/src/Makefile b/lib/stdlib/src/Makefile index 9f4a446ea0..c95f7637f7 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-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. @@ -51,7 +51,6 @@ MODULES= \ dets_server \ dets_sup \ dets_utils \ - dets_v8 \ dets_v9 \ dict \ digraph \ @@ -59,9 +58,11 @@ MODULES= \ edlin \ edlin_expand \ epp \ + erl_abstract_code \ erl_anno \ erl_bits \ erl_compile \ + erl_error \ erl_eval \ erl_expand_records \ erl_internal \ @@ -85,12 +86,12 @@ MODULES= \ gen_event \ gen_fsm \ gen_server \ + gen_statem \ io \ io_lib \ io_lib_format \ io_lib_fread \ io_lib_pretty \ - lib \ lists \ log_mf_h \ maps \ @@ -119,6 +120,8 @@ MODULES= \ sys \ timer \ unicode \ + unicode_util \ + uri_string \ win32reg \ zip @@ -130,7 +133,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) @@ -173,6 +176,7 @@ docs: primary_bootstrap_compiler: \ $(BOOTSTRAP_COMPILER)/ebin/epp.beam \ $(BOOTSTRAP_COMPILER)/ebin/erl_anno.beam \ + $(BOOTSTRAP_COMPILER)/ebin/erl_error.beam \ $(BOOTSTRAP_COMPILER)/ebin/erl_scan.beam \ $(BOOTSTRAP_COMPILER)/ebin/erl_parse.beam \ $(BOOTSTRAP_COMPILER)/ebin/erl_lint.beam \ @@ -200,6 +204,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,15 +231,21 @@ $(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 +$(EBIN)/gen_event.beam: ../../kernel/include/logger.hrl +$(EBIN)/gen_fsm.beam: ../../kernel/include/logger.hrl +$(EBIN)/gen_server.beam: ../../kernel/include/logger.hrl +$(EBIN)/gen_statem.beam: ../../kernel/include/logger.hrl +$(EBIN)/proc_lib.beam: ../../kernel/include/logger.hrl $(EBIN)/qlc_pt.beam: ../include/ms_transform.hrl $(EBIN)/shell.beam: ../../kernel/include/file.hrl +$(EBIN)/supervisor.beam: ../../kernel/include/logger.hrl +$(EBIN)/supervisor_bridge.beam: ../../kernel/include/logger.hrl $(EBIN)/zip.beam: ../include/zip.hrl ../../kernel/include/file.hrl diff --git a/lib/stdlib/src/array.erl b/lib/stdlib/src/array.erl index c749dd008b..939b1fb488 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. @@ -296,7 +290,7 @@ new(Size, Fixed, Default) -> end, #array{size = Size, max = M, default = Default, elements = E}. --spec find_max(integer(), integer()) -> integer(). +-spec find_max(integer(), non_neg_integer()) -> non_neg_integer(). find_max(I, M) when I >= M -> find_max(I, ?extend(M)); @@ -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..6ea4147abf 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. @@ -24,22 +24,11 @@ -export([encode/1, decode/1, mime_decode/1, encode_to_string/1, decode_to_string/1, mime_decode_to_string/1]). -%%------------------------------------------------------------------------- %% The following type is a subtype of string() for return values %% of (some) functions of this module. -%%------------------------------------------------------------------------- - -type ascii_string() :: [1..255]. -type ascii_binary() :: binary(). -%%------------------------------------------------------------------------- -%% encode_to_string(ASCII) -> Base64String -%% ASCII - string() | binary() -%% Base64String - string() -%% -%% Description: Encodes a plain ASCII string (or binary) into base64. -%%------------------------------------------------------------------------- - -spec encode_to_string(Data) -> Base64String when Data :: ascii_string() | ascii_binary(), Base64String :: ascii_string(). @@ -47,107 +36,89 @@ encode_to_string(Bin) when is_binary(Bin) -> encode_to_string(binary_to_list(Bin)); encode_to_string(List) when is_list(List) -> - encode_l(List). - -%%------------------------------------------------------------------------- -%% encode(ASCII) -> Base64 -%% ASCII - string() | binary() -%% Base64 - binary() -%% -%% Description: Encodes a plain ASCII string (or binary) into base64. -%%------------------------------------------------------------------------- + encode_list_to_string(List). -spec encode(Data) -> Base64 when Data :: ascii_string() | ascii_binary(), Base64 :: ascii_binary(). encode(Bin) when is_binary(Bin) -> - encode_binary(Bin); + encode_binary(Bin, <<>>); encode(List) when is_list(List) -> - list_to_binary(encode_l(List)). + encode_list(List, <<>>). --spec encode_l(ascii_string()) -> ascii_string(). - -encode_l([]) -> +encode_list_to_string([]) -> []; -encode_l([A]) -> - [b64e(A bsr 2), - b64e((A band 3) bsl 4), $=, $=]; -encode_l([A,B]) -> - [b64e(A bsr 2), - b64e(((A band 3) bsl 4) bor (B bsr 4)), - b64e((B band 15) bsl 2), $=]; -encode_l([A,B,C|Ls]) -> - BB = (A bsl 16) bor (B bsl 8) bor C, +encode_list_to_string([B1]) -> + [b64e(B1 bsr 2), + b64e((B1 band 3) bsl 4), $=, $=]; +encode_list_to_string([B1,B2]) -> + [b64e(B1 bsr 2), + b64e(((B1 band 3) bsl 4) bor (B2 bsr 4)), + b64e((B2 band 15) bsl 2), $=]; +encode_list_to_string([B1,B2,B3|Ls]) -> + BB = (B1 bsl 16) bor (B2 bsl 8) bor B3, [b64e(BB bsr 18), b64e((BB bsr 12) band 63), b64e((BB bsr 6) band 63), - b64e(BB band 63) | encode_l(Ls)]. - -encode_binary(Bin) -> - Split = 3*(byte_size(Bin) div 3), - <<Main0:Split/binary,Rest/binary>> = Bin, - Main = << <<(b64e(C)):8>> || <<C:6>> <= Main0 >>, - case Rest of - <<A:6,B:6,C:4>> -> - <<Main/binary,(b64e(A)):8,(b64e(B)):8,(b64e(C bsl 2)):8,$=:8>>; - <<A:6,B:2>> -> - <<Main/binary,(b64e(A)):8,(b64e(B bsl 4)):8,$=:8,$=:8>>; - <<>> -> - Main - end. + b64e(BB band 63) | encode_list_to_string(Ls)]. -%%------------------------------------------------------------------------- -%% mime_decode(Base64) -> ASCII -%% decode(Base64) -> ASCII -%% Base64 - string() | binary() -%% ASCII - binary() -%% -%% Description: Decodes an base64 encoded string to plain ASCII. -%% mime_decode strips away all characters not Base64 before converting, -%% whereas decode crashes if an illegal character is found -%%------------------------------------------------------------------------- +encode_binary(<<>>, A) -> + A; +encode_binary(<<B1:8>>, A) -> + <<A/bits,(b64e(B1 bsr 2)):8,(b64e((B1 band 3) bsl 4)):8,$=:8,$=:8>>; +encode_binary(<<B1:8, B2:8>>, A) -> + <<A/bits,(b64e(B1 bsr 2)):8, + (b64e(((B1 band 3) bsl 4) bor (B2 bsr 4))):8, + (b64e((B2 band 15) bsl 2)):8, $=:8>>; +encode_binary(<<B1:8, B2:8, B3:8, Ls/bits>>, A) -> + BB = (B1 bsl 16) bor (B2 bsl 8) bor B3, + encode_binary(Ls, + <<A/bits,(b64e(BB bsr 18)):8, + (b64e((BB bsr 12) band 63)):8, + (b64e((BB bsr 6) band 63)):8, + (b64e(BB band 63)):8>>). + +encode_list([], A) -> + A; +encode_list([B1], A) -> + <<A/bits,(b64e(B1 bsr 2)):8,(b64e((B1 band 3) bsl 4)):8,$=:8,$=:8>>; +encode_list([B1,B2], A) -> + <<A/bits,(b64e(B1 bsr 2)):8, + (b64e(((B1 band 3) bsl 4) bor (B2 bsr 4))):8, + (b64e((B2 band 15) bsl 2)):8, $=:8>>; +encode_list([B1,B2,B3|Ls], A) -> + BB = (B1 bsl 16) bor (B2 bsl 8) bor B3, + encode_list(Ls, + <<A/bits,(b64e(BB bsr 18)):8, + (b64e((BB bsr 12) band 63)):8, + (b64e((BB bsr 6) band 63)):8, + (b64e(BB band 63)):8>>). + +%% mime_decode strips away all characters not Base64 before +%% converting, whereas decode crashes if an illegal character is found -spec decode(Base64) -> Data when Base64 :: ascii_string() | ascii_binary(), Data :: ascii_binary(). decode(Bin) when is_binary(Bin) -> - decode_binary(<<>>, Bin); + decode_binary(Bin, <<>>); decode(List) when is_list(List) -> - list_to_binary(decode_l(List)). + decode_list(List, <<>>). -spec mime_decode(Base64) -> Data when Base64 :: ascii_string() | ascii_binary(), Data :: ascii_binary(). mime_decode(Bin) when is_binary(Bin) -> - mime_decode_binary(<<>>, Bin); + mime_decode_binary(Bin, <<>>); mime_decode(List) when is_list(List) -> - mime_decode(list_to_binary(List)). - --spec decode_l(ascii_string()) -> ascii_string(). - -decode_l(List) -> - L = strip_spaces(List, []), - decode(L, []). - --spec mime_decode_l(ascii_string()) -> ascii_string(). + mime_decode_list(List, <<>>). -mime_decode_l(List) -> - L = strip_illegal(List, [], 0), - decode(L, []). - -%%------------------------------------------------------------------------- -%% mime_decode_to_string(Base64) -> ASCII -%% decode_to_string(Base64) -> ASCII -%% Base64 - string() | binary() -%% ASCII - binary() -%% -%% Description: Decodes an base64 encoded string to plain ASCII. -%% mime_decode strips away all characters not Base64 before converting, -%% whereas decode crashes if an illegal character is found -%%------------------------------------------------------------------------- +%% mime_decode_to_string strips away all characters not Base64 before +%% converting, whereas decode_to_string crashes if an illegal +%% character is found -spec decode_to_string(Base64) -> DataString when Base64 :: ascii_string() | ascii_binary(), @@ -156,7 +127,7 @@ mime_decode_l(List) -> decode_to_string(Bin) when is_binary(Bin) -> decode_to_string(binary_to_list(Bin)); decode_to_string(List) when is_list(List) -> - decode_l(List). + decode_list_to_string(List). -spec mime_decode_to_string(Base64) -> DataString when Base64 :: ascii_string() | ascii_binary(), @@ -165,191 +136,326 @@ decode_to_string(List) when is_list(List) -> mime_decode_to_string(Bin) when is_binary(Bin) -> mime_decode_to_string(binary_to_list(Bin)); mime_decode_to_string(List) when is_list(List) -> - mime_decode_l(List). - -%% One-based decode map. --define(DECODE_MAP, - {bad,bad,bad,bad,bad,bad,bad,bad,ws,ws,bad,bad,ws,bad,bad, %1-15 - bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, %16-31 - ws,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,62,bad,bad,bad,63, %32-47 - 52,53,54,55,56,57,58,59,60,61,bad,bad,bad,eq,bad,bad, %48-63 - bad,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14, - 15,16,17,18,19,20,21,22,23,24,25,bad,bad,bad,bad,bad, - bad,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40, - 41,42,43,44,45,46,47,48,49,50,51,bad,bad,bad,bad,bad, - bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, - bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, - bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, - bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, - bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, - bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, - bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, - bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad}). - -decode_binary(Result0, <<C:8,T0/bits>>) -> - case element(C, ?DECODE_MAP) of - bad -> - erlang:error({badarg,C}); - ws -> - decode_binary(Result0, T0); - eq -> - case strip_ws(T0) of - <<$=:8,T/binary>> -> - <<>> = strip_ws(T), - Split = byte_size(Result0) - 1, - <<Result:Split/bytes,_:4>> = Result0, - Result; - T -> - <<>> = strip_ws(T), - Split = byte_size(Result0) - 1, - <<Result:Split/bytes,_:2>> = Result0, - Result - end; - Bits -> - decode_binary(<<Result0/bits,Bits:6>>, T0) - end; -decode_binary(Result, <<>>) -> - true = is_binary(Result), - Result. + mime_decode_list_to_string(List). %% Skipping pad character if not at end of string. Also liberal about %% excess padding and skipping of other illegal (non-base64 alphabet) %% characters. See section 3.3 of RFC4648 -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) +mime_decode_list([0 | Cs], A) -> + mime_decode_list(Cs, A); +mime_decode_list([C1 | Cs], A) -> + case b64d(C1) of + B1 when is_integer(B1) -> mime_decode_list(Cs, A, B1); + _ -> mime_decode_list(Cs, A) % eq is padding end; -mime_decode_binary(Result, <<>>) -> - true = is_binary(Result), - Result. - -decode([], A) -> A; -decode([$=,$=,C2,C1|Cs], A) -> - Bits2x6 = (b64d(C1) bsl 18) bor (b64d(C2) bsl 12), - Octet1 = Bits2x6 bsr 16, - decode(Cs, [Octet1|A]); -decode([$=,C3,C2,C1|Cs], A) -> - Bits3x6 = (b64d(C1) bsl 18) bor (b64d(C2) bsl 12) - bor (b64d(C3) bsl 6), - Octet1 = Bits3x6 bsr 16, - Octet2 = (Bits3x6 bsr 8) band 16#ff, - decode(Cs, [Octet1,Octet2|A]); -decode([C4,C3,C2,C1| Cs], A) -> - Bits4x6 = (b64d(C1) bsl 18) bor (b64d(C2) bsl 12) - bor (b64d(C3) bsl 6) bor b64d(C4), - Octet1 = Bits4x6 bsr 16, - Octet2 = (Bits4x6 bsr 8) band 16#ff, - Octet3 = Bits4x6 band 16#ff, - decode(Cs, [Octet1,Octet2,Octet3|A]). +mime_decode_list([], A) -> + A. + +mime_decode_list([0 | Cs], A, B1) -> + mime_decode_list(Cs, A, B1); +mime_decode_list([C2 | Cs], A, B1) -> + case b64d(C2) of + B2 when is_integer(B2) -> + mime_decode_list(Cs, A, B1, B2); + _ -> mime_decode_list(Cs, A, B1) % eq is padding + end. -%%%======================================================================== -%%% Internal functions -%%%======================================================================== +mime_decode_list([0 | Cs], A, B1, B2) -> + mime_decode_list(Cs, A, B1, B2); +mime_decode_list([C3 | Cs], A, B1, B2) -> + case b64d(C3) of + B3 when is_integer(B3) -> + mime_decode_list(Cs, A, B1, B2, B3); + eq=B3 -> + mime_decode_list_after_eq(Cs, A, B1, B2, B3); + _ -> mime_decode_list(Cs, A, B1, B2) + end. -strip_spaces([], A) -> A; -strip_spaces([$\s|Cs], A) -> strip_spaces(Cs, A); -strip_spaces([$\t|Cs], A) -> strip_spaces(Cs, A); -strip_spaces([$\r|Cs], A) -> strip_spaces(Cs, A); -strip_spaces([$\n|Cs], A) -> strip_spaces(Cs, A); -strip_spaces([C|Cs], A) -> strip_spaces(Cs, [C | A]). - -strip_ws(<<$\t,T/binary>>) -> - strip_ws(T); -strip_ws(<<$\n,T/binary>>) -> - strip_ws(T); -strip_ws(<<$\r,T/binary>>) -> - strip_ws(T); -strip_ws(<<$\s,T/binary>>) -> - strip_ws(T); -strip_ws(T) -> T. +mime_decode_list([0 | Cs], A, B1, B2, B3) -> + mime_decode_list(Cs, A, B1, B2, B3); +mime_decode_list([C4 | Cs], A, B1, B2, B3) -> + case b64d(C4) of + B4 when is_integer(B4) -> + mime_decode_list(Cs, <<A/bits,B1:6,B2:6,B3:6,B4:6>>); + eq -> + mime_decode_list_after_eq(Cs, A, B1, B2, B3); + _ -> mime_decode_list(Cs, A, B1, B2, B3) + end. -%% Skipping pad character if not at end of string. Also liberal about -%% excess padding and skipping of other illegal (non-base64 alphabet) -%% characters. See section 3.3 of RFC4648 -strip_illegal([], A, _Cnt) -> +mime_decode_list_after_eq([0 | Cs], A, B1, B2, B3) -> + mime_decode_list_after_eq(Cs, A, B1, B2, B3); +mime_decode_list_after_eq([C | Cs], A, B1, B2, B3) -> + case b64d(C) of + B when is_integer(B) -> + %% More valid data, skip the eq as invalid + case B3 of + eq -> mime_decode_list(Cs, A, B1, B2, B); + _ -> mime_decode_list(Cs, <<A/bits,B1:6,B2:6,B3:6,B:6>>) + end; + _ -> mime_decode_list_after_eq(Cs, A, B1, B2, B3) + end; +mime_decode_list_after_eq([], A, B1, B2, eq) -> + <<A/bits,B1:6,(B2 bsr 4):2>>; +mime_decode_list_after_eq([], A, B1, B2, B3) -> + <<A/bits,B1:6,B2:6,(B3 bsr 2):4>>. + +mime_decode_binary(<<0:8, Cs/bits>>, A) -> + mime_decode_binary(Cs, A); +mime_decode_binary(<<C1:8, Cs/bits>>, A) -> + case b64d(C1) of + B1 when is_integer(B1) -> mime_decode_binary(Cs, A, B1); + _ -> mime_decode_binary(Cs, A) % eq is padding + end; +mime_decode_binary(<<>>, A) -> + A. + +mime_decode_binary(<<0:8, Cs/bits>>, A, B1) -> + mime_decode_binary(Cs, A, B1); +mime_decode_binary(<<C2:8, Cs/bits>>, A, B1) -> + case b64d(C2) of + B2 when is_integer(B2) -> + mime_decode_binary(Cs, A, B1, B2); + _ -> mime_decode_binary(Cs, A, B1) % eq is padding + end. + +mime_decode_binary(<<0:8, Cs/bits>>, A, B1, B2) -> + mime_decode_binary(Cs, A, B1, B2); +mime_decode_binary(<<C3:8, Cs/bits>>, A, B1, B2) -> + case b64d(C3) of + B3 when is_integer(B3) -> + mime_decode_binary(Cs, A, B1, B2, B3); + eq=B3 -> + mime_decode_binary_after_eq(Cs, A, B1, B2, B3); + _ -> mime_decode_binary(Cs, A, B1, B2) + end. + +mime_decode_binary(<<0:8, Cs/bits>>, A, B1, B2, B3) -> + mime_decode_binary(Cs, A, B1, B2, B3); +mime_decode_binary(<<C4:8, Cs/bits>>, A, B1, B2, B3) -> + case b64d(C4) of + B4 when is_integer(B4) -> + mime_decode_binary(Cs, <<A/bits,B1:6,B2:6,B3:6,B4:6>>); + eq -> + mime_decode_binary_after_eq(Cs, A, B1, B2, B3); + _ -> mime_decode_binary(Cs, A, B1, B2, B3) + end. + +mime_decode_binary_after_eq(<<0:8, Cs/bits>>, A, B1, B2, B3) -> + mime_decode_binary_after_eq(Cs, A, B1, B2, B3); +mime_decode_binary_after_eq(<<C:8, Cs/bits>>, A, B1, B2, B3) -> + case b64d(C) of + B when is_integer(B) -> + %% More valid data, skip the eq as invalid + case B3 of + eq -> mime_decode_binary(Cs, A, B1, B2, B); + _ -> mime_decode_binary(Cs, <<A/bits,B1:6,B2:6,B3:6,B:6>>) + end; + _ -> mime_decode_binary_after_eq(Cs, A, B1, B2, B3) + end; +mime_decode_binary_after_eq(<<>>, A, B1, B2, eq) -> + <<A/bits,B1:6,(B2 bsr 4):2>>; +mime_decode_binary_after_eq(<<>>, A, B1, B2, B3) -> + <<A/bits,B1:6,B2:6,(B3 bsr 2):4>>. + +mime_decode_list_to_string([0 | Cs]) -> + mime_decode_list_to_string(Cs); +mime_decode_list_to_string([C1 | Cs]) -> + case b64d(C1) of + B1 when is_integer(B1) -> mime_decode_list_to_string(Cs, B1); + _ -> mime_decode_list_to_string(Cs) % eq is padding + end; +mime_decode_list_to_string([]) -> + []. + +mime_decode_list_to_string([0 | Cs], B1) -> + mime_decode_list_to_string(Cs, B1); +mime_decode_list_to_string([C2 | Cs], B1) -> + case b64d(C2) of + B2 when is_integer(B2) -> + mime_decode_list_to_string(Cs, B1, B2); + _ -> mime_decode_list_to_string(Cs, B1) % eq is padding + end. + +mime_decode_list_to_string([0 | Cs], B1, B2) -> + mime_decode_list_to_string(Cs, B1, B2); +mime_decode_list_to_string([C3 | Cs], B1, B2) -> + case b64d(C3) of + B3 when is_integer(B3) -> + mime_decode_list_to_string(Cs, B1, B2, B3); + eq=B3 -> mime_decode_list_to_string_after_eq(Cs, B1, B2, B3); + _ -> mime_decode_list_to_string(Cs, B1, B2) + end. + +mime_decode_list_to_string([0 | Cs], B1, B2, B3) -> + mime_decode_list_to_string(Cs, B1, B2, B3); +mime_decode_list_to_string([C4 | Cs], B1, B2, B3) -> + case b64d(C4) of + B4 when is_integer(B4) -> + Bits4x6 = (B1 bsl 18) bor (B2 bsl 12) bor (B3 bsl 6) bor B4, + Octet1 = Bits4x6 bsr 16, + Octet2 = (Bits4x6 bsr 8) band 16#ff, + Octet3 = Bits4x6 band 16#ff, + [Octet1, Octet2, Octet3 | mime_decode_list_to_string(Cs)]; + eq -> + mime_decode_list_to_string_after_eq(Cs, B1, B2, B3); + _ -> mime_decode_list_to_string(Cs, B1, B2, B3) + end. + +mime_decode_list_to_string_after_eq([0 | Cs], B1, B2, B3) -> + mime_decode_list_to_string_after_eq(Cs, B1, B2, B3); +mime_decode_list_to_string_after_eq([C | Cs], B1, B2, B3) -> + case b64d(C) of + B when is_integer(B) -> + %% More valid data, skip the eq as invalid + case B3 of + eq -> mime_decode_list_to_string(Cs, B1, B2, B); + _ -> + Bits4x6 = (B1 bsl 18) bor (B2 bsl 12) bor (B3 bsl 6) bor B, + Octet1 = Bits4x6 bsr 16, + Octet2 = (Bits4x6 bsr 8) band 16#ff, + Octet3 = Bits4x6 band 16#ff, + [Octet1, Octet2, Octet3 | mime_decode_list_to_string(Cs)] + end; + _ -> mime_decode_list_to_string_after_eq(Cs, B1, B2, B3) + end; +mime_decode_list_to_string_after_eq([], B1, B2, eq) -> + binary_to_list(<<B1:6,(B2 bsr 4):2>>); +mime_decode_list_to_string_after_eq([], B1, B2, B3) -> + binary_to_list(<<B1:6,B2:6,(B3 bsr 2):4>>). + +decode_list([C1 | Cs], A) -> + case b64d(C1) of + ws -> decode_list(Cs, A); + B1 -> decode_list(Cs, A, B1) + end; +decode_list([], A) -> + A. + +decode_list([C2 | Cs], A, B1) -> + case b64d(C2) of + ws -> decode_list(Cs, A, B1); + B2 -> decode_list(Cs, A, B1, B2) + end. + +decode_list([C3 | Cs], A, B1, B2) -> + case b64d(C3) of + ws -> decode_list(Cs, A, B1, B2); + B3 -> decode_list(Cs, A, B1, B2, B3) + end. + +decode_list([C4 | Cs], A, B1, B2, B3) -> + case b64d(C4) of + ws -> decode_list(Cs, A, B1, B2, B3); + eq when B3 =:= eq -> only_ws(Cs, <<A/bits,B1:6,(B2 bsr 4):2>>); + eq -> only_ws(Cs, <<A/bits,B1:6,B2:6,(B3 bsr 2):4>>); + B4 -> decode_list(Cs, <<A/bits,B1:6,B2:6,B3:6,B4:6>>) + end. + +decode_binary(<<C1:8, Cs/bits>>, A) -> + case b64d(C1) of + ws -> decode_binary(Cs, A); + B1 -> decode_binary(Cs, A, B1) + end; +decode_binary(<<>>, A) -> + A. + +decode_binary(<<C2:8, Cs/bits>>, A, B1) -> + case b64d(C2) of + ws -> decode_binary(Cs, A, B1); + B2 -> decode_binary(Cs, A, B1, B2) + end. + +decode_binary(<<C3:8, Cs/bits>>, A, B1, B2) -> + case b64d(C3) of + ws -> decode_binary(Cs, A, B1, B2); + B3 -> decode_binary(Cs, A, B1, B2, B3) + end. + +decode_binary(<<C4:8, Cs/bits>>, A, B1, B2, B3) -> + case b64d(C4) of + ws -> decode_binary(Cs, A, B1, B2, B3); + eq when B3 =:= eq -> only_ws_binary(Cs, <<A/bits,B1:6,(B2 bsr 4):2>>); + eq -> only_ws_binary(Cs, <<A/bits,B1:6,B2:6,(B3 bsr 2):4>>); + B4 -> decode_binary(Cs, <<A/bits,B1:6,B2:6,B3:6,B4:6>>) + end. + +only_ws_binary(<<>>, A) -> A; -strip_illegal([0|Cs], A, Cnt) -> - strip_illegal(Cs, A, Cnt); -strip_illegal([C|Cs], A, Cnt) -> - case element(C, ?DECODE_MAP) of - bad -> - strip_illegal(Cs, A, Cnt); - ws -> - strip_illegal(Cs, A, Cnt); - eq -> - case {tail_contains_more(Cs, false), Cnt rem 4} of - {{[], _}, 0} -> - A; %% Ignore extra = - {{[], true}, 2} -> - [$=|[$=|A]]; %% 'XX==' - {{[], _}, 3} -> - [$=|A]; %% 'XXX=' - {{[H|T], _}, _} -> - %% more data, skip equals - strip_illegal(T, [H|A], Cnt+1) - end; - _ -> - strip_illegal(Cs, [C|A], Cnt+1) +only_ws_binary(<<C:8, Cs/bits>>, A) -> + case b64d(C) of + ws -> only_ws_binary(Cs, A) end. -%% Search the tail for more valid data and remember if we saw -%% another equals along the way. -tail_contains_more([], Eq) -> - {[], Eq}; -tail_contains_more(<<>>, Eq) -> - {<<>>, Eq}; -tail_contains_more([C|T]=More, Eq) -> - case element(C, ?DECODE_MAP) of - bad -> - tail_contains_more(T, Eq); - ws -> - tail_contains_more(T, Eq); - eq -> - tail_contains_more(T, true); - _ -> - {More, Eq} +decode_list_to_string([C1 | Cs]) -> + case b64d(C1) of + ws -> decode_list_to_string(Cs); + B1 -> decode_list_to_string(Cs, B1) end; -tail_contains_more(<<C:8,T/bits>> =More, Eq) -> - case element(C, ?DECODE_MAP) of - bad -> - tail_contains_more(T, Eq); - ws -> - tail_contains_more(T, Eq); - eq -> - tail_contains_more(T, true); - _ -> - {More, Eq} +decode_list_to_string([]) -> + []. + +decode_list_to_string([C2 | Cs], B1) -> + case b64d(C2) of + ws -> decode_list_to_string(Cs, B1); + B2 -> decode_list_to_string(Cs, B1, B2) + end. + +decode_list_to_string([C3 | Cs], B1, B2) -> + case b64d(C3) of + ws -> decode_list_to_string(Cs, B1, B2); + B3 -> decode_list_to_string(Cs, B1, B2, B3) + end. + +decode_list_to_string([C4 | Cs], B1, B2, B3) -> + case b64d(C4) of + ws -> + decode_list_to_string(Cs, B1, B2, B3); + eq when B3 =:= eq -> + only_ws(Cs, binary_to_list(<<B1:6,(B2 bsr 4):2>>)); + eq -> + only_ws(Cs, binary_to_list(<<B1:6,B2:6,(B3 bsr 2):4>>)); + B4 -> + Bits4x6 = (B1 bsl 18) bor (B2 bsl 12) bor (B3 bsl 6) bor B4, + Octet1 = Bits4x6 bsr 16, + Octet2 = (Bits4x6 bsr 8) band 16#ff, + Octet3 = Bits4x6 band 16#ff, + [Octet1, Octet2, Octet3 | decode_list_to_string(Cs)] end. - + +only_ws([], A) -> + A; +only_ws([C | Cs], A) -> + case b64d(C) of + ws -> only_ws(Cs, A) + end. + +%%%======================================================================== +%%% Internal functions +%%%======================================================================== + %% accessors +-compile({inline, [{b64d, 1}]}). +%% One-based decode map. +b64d(X) -> + element(X, + {bad,bad,bad,bad,bad,bad,bad,bad,ws,ws,bad,bad,ws,bad,bad, %1-15 + bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, %16-31 + ws,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,62,bad,bad,bad,63, %32-47 + 52,53,54,55,56,57,58,59,60,61,bad,bad,bad,eq,bad,bad, %48-63 + bad,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14, + 15,16,17,18,19,20,21,22,23,24,25,bad,bad,bad,bad,bad, + bad,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40, + 41,42,43,44,45,46,47,48,49,50,51,bad,bad,bad,bad,bad, + bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, + bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, + bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, + bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, + bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, + bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, + bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad, + bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad,bad}). + +-compile({inline, [{b64e, 1}]}). b64e(X) -> element(X+1, {$A, $B, $C, $D, $E, $F, $G, $H, $I, $J, $K, $L, $M, $N, @@ -357,9 +463,3 @@ b64e(X) -> $a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $k, $l, $m, $n, $o, $p, $q, $r, $s, $t, $u, $v, $w, $x, $y, $z, $0, $1, $2, $3, $4, $5, $6, $7, $8, $9, $+, $/}). - - -b64d(X) -> - b64d_ok(element(X, ?DECODE_MAP)). - -b64d_ok(I) when is_integer(I) -> I. diff --git a/lib/stdlib/src/beam_lib.erl b/lib/stdlib/src/beam_lib.erl index 503a2b416f..01181b1097 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-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. @@ -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()} @@ -145,7 +148,8 @@ chunks(File, Chunks, Options) -> try read_chunk_data(File, Chunks, Options) catch Error -> Error end. --spec all_chunks(beam()) -> {'ok', 'beam_lib', [{chunkid(), dataB()}]}. +-spec all_chunks(beam()) -> + {'ok', 'beam_lib', [{chunkid(), dataB()}]} | {'error', 'beam_lib', info_rsn()}. all_chunks(File) -> read_all_chunks(File). @@ -267,9 +271,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) -> @@ -510,9 +514,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, []) @@ -520,25 +524,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. @@ -581,18 +594,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) -> @@ -624,6 +642,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), @@ -646,20 +683,38 @@ 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, anno_from_term(Term)}}; + _ -> + case catch binary_to_term(Chunk) of + {'EXIT', _} -> + error({invalid_chunk, File, chunk_name_to_id(Id, File)}); + Term -> + {AtomTable, {Id, anno_from_term(Term)}} + end + end; chunk_to_data(abstract_code=Id, Chunk, File, _Cs, AtomTable, Mod) -> + %% Before Erlang/OTP 20.0. 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, old_anno_from_term(Term)}}; _ -> case catch binary_to_term(Chunk) of {'EXIT', _} -> error({invalid_chunk, File, chunk_name_to_id(Id, File)}); Term -> try - {AtomTable, {Id, anno_from_term(Term)}} + {AtomTable, {Id, old_anno_from_term(Term)}} catch _:_ -> error({invalid_chunk, File, @@ -683,7 +738,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"; @@ -692,6 +746,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}). @@ -738,25 +793,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. @@ -856,12 +916,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. @@ -872,39 +932,48 @@ 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}) -> +old_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 -> +old_anno_from_term({Tag, Forms}) when Tag =:= abstract_v1; + Tag =:= abstract_v2 -> try {Tag, anno_from_forms(Forms)} catch _:_ -> {Tag, Forms} end; +old_anno_from_term(T) -> + T. + +anno_from_term({debug_info_v1=Tag1, erl_abstract_code=Tag2, {Forms, Opts}}) -> + try {Tag1, Tag2, {anno_from_forms(Forms), Opts}} + catch + _:_ -> + {Tag1, Tag2, {Forms, Opts}} + end; 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() -> @@ -975,9 +1044,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..52b9fedc9c 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-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. @@ -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(), @@ -46,23 +47,39 @@ at(_, _) -> -spec bin_to_list(Subject) -> [byte()] when Subject :: binary(). -bin_to_list(_) -> - erlang:nif_error(undef). +bin_to_list(Subject) -> + binary_to_list(Subject). -spec bin_to_list(Subject, PosLen) -> [byte()] when Subject :: binary(), PosLen :: part(). -bin_to_list(_, _) -> - erlang:nif_error(undef). +bin_to_list(Subject, {Pos, Len}) -> + bin_to_list(Subject, Pos, Len); +bin_to_list(_Subject, _BadArg) -> + erlang:error(badarg). -spec bin_to_list(Subject, Pos, Len) -> [byte()] when Subject :: binary(), Pos :: non_neg_integer(), Len :: integer(). -bin_to_list(_, _, _) -> - erlang:nif_error(undef). +bin_to_list(Subject, Pos, Len) when not is_binary(Subject); + not is_integer(Pos); + not is_integer(Len) -> + %% binary_to_list/3 allows bitstrings as long as the slice fits, and we + %% want to badarg when Pos/Len aren't integers instead of raising badarith + %% when adjusting args for binary_to_list/3. + erlang:error(badarg); +bin_to_list(Subject, Pos, 0) when Pos >= 0, Pos =< byte_size(Subject) -> + %% binary_to_list/3 doesn't handle this case. + []; +bin_to_list(_Subject, _Pos, 0) -> + erlang:error(badarg); +bin_to_list(Subject, Pos, Len) when Len < 0 -> + bin_to_list(Subject, Pos + Len, -Len); +bin_to_list(Subject, Pos, Len) when Len > 0 -> + binary_to_list(Subject, Pos + 1, Pos + Len). -spec compile_pattern(Pattern) -> cp() when Pattern :: binary() | [binary()]. @@ -198,19 +215,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 +230,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 +320,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..0362b72536 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-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,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(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. -c(File, Opts0) when is_list(Opts0) -> - Opts = [report_errors,report_warnings|Opts0], +%% 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). @@ -366,7 +564,7 @@ display_info(Pid) -> Other end, Reds = fetch(reductions, Info), - LM = length(fetch(messages, Info)), + LM = fetch(message_queue_len, Info), HS = fetch(heap_size, Info), SS = fetch(stack_size, Info), iformat(w(Pid), mfa_string(Call), @@ -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,20 +657,34 @@ 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. +%% Try to run a ".erlang" file in home directory. + +-spec erlangrc() -> {ok, file:filename()} | {error, term()}. erlangrc() -> case init:get_argument(home) of {ok,[[Home]]} -> erlangrc([Home]); _ -> - f_p_e(["."], ".erlang") + {error, enoent} end. -erlangrc([Home]) -> - f_p_e([".",Home], ".erlang"). +-spec erlangrc(PathList) -> {ok, file:filename()} | {error, term()} + when PathList :: [Dir :: file:name()]. + +erlangrc([Home|_]=Paths) when is_list(Home) -> + f_p_e(Paths, ".erlang"). error(Fmt, Args) -> error_logger:error_msg(Fmt, Args). @@ -484,11 +696,11 @@ f_p_e(P, F) -> {error, E={Line, _Mod, _Term}} -> error("file:path_eval(~tp,~tp): error on line ~p: ~ts~n", [P, F, Line, file:format_error(E)]), - ok; + {error, E}; {error, E} -> error("file:path_eval(~tp,~tp): ~ts~n", [P, F, file:format_error(E)]), - ok; + {error, E}; Other -> Other end. @@ -559,7 +771,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 +783,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. @@ -674,23 +886,23 @@ portinfo(Id) -> procline(Name, Info, Pid) -> Call = initial_call(Info), Reds = fetch(reductions, Info), - LM = length(fetch(messages, Info)), - procformat(io_lib:format("~w",[Name]), + LM = fetch(message_queue_len, Info), + 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) @@ -822,8 +1034,8 @@ appcall(App, M, F, Args) -> try apply(M, F, Args) catch - error:undef -> - case erlang:get_stacktrace() of + error:undef:S -> + case S of [{M,F,Args,_}|_] -> Arity = length(Args), io:format("Call to ~w:~w/~w in application ~w failed.\n", diff --git a/lib/stdlib/src/calendar.erl b/lib/stdlib/src/calendar.erl index 074c504e00..9a600c1972 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-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. @@ -39,8 +39,14 @@ now_to_datetime/1, % = now_to_universal_time/1 now_to_local_time/1, now_to_universal_time/1, + rfc3339_to_system_time/1, + rfc3339_to_system_time/2, seconds_to_daystime/1, seconds_to_time/1, + system_time_to_local_time/2, + system_time_to_universal_time/2, + system_time_to_rfc3339/1, + system_time_to_rfc3339/2, time_difference/2, time_to_seconds/1, universal_time/0, @@ -55,10 +61,13 @@ -define(SECONDS_PER_DAY, 86400). -define(DAYS_PER_YEAR, 365). -define(DAYS_PER_LEAP_YEAR, 366). --define(DAYS_PER_4YEARS, 1461). --define(DAYS_PER_100YEARS, 36524). --define(DAYS_PER_400YEARS, 146097). +%% -define(DAYS_PER_4YEARS, 1461). +%% -define(DAYS_PER_100YEARS, 36524). +%% -define(DAYS_PER_400YEARS, 146097). -define(DAYS_FROM_0_TO_1970, 719528). +-define(DAYS_FROM_0_TO_10000, 2932897). +-define(SECONDS_FROM_0_TO_1970, (?DAYS_FROM_0_TO_1970*?SECONDS_PER_DAY)). +-define(SECONDS_FROM_0_TO_10000, (?DAYS_FROM_0_TO_10000*?SECONDS_PER_DAY)). %%---------------------------------------------------------------------- %% Types @@ -83,6 +92,13 @@ -type datetime1970() :: {{year1970(),month(),day()},time()}. -type yearweeknum() :: {year(),weeknum()}. +-type rfc3339_string() :: [byte(), ...]. +%% By design 'native' is not supported: +-type rfc3339_time_unit() :: 'microsecond' + | 'millisecond' + | 'nanosecond' + | 'second'. + %%---------------------------------------------------------------------- %% All dates are according the the Gregorian calendar. In this module @@ -309,8 +325,7 @@ local_time_to_universal_time_dst(DateTime) -> -spec now_to_datetime(Now) -> datetime1970() when Now :: erlang:timestamp(). now_to_datetime({MSec, Sec, _uSec}) -> - Sec0 = MSec*1000000 + Sec + ?DAYS_FROM_0_TO_1970*?SECONDS_PER_DAY, - gregorian_seconds_to_datetime(Sec0). + system_time_to_datetime(MSec*1000000 + Sec). -spec now_to_universal_time(Now) -> datetime1970() when Now :: erlang:timestamp(). @@ -328,6 +343,33 @@ now_to_local_time({MSec, Sec, _uSec}) -> erlang:universaltime_to_localtime( now_to_universal_time({MSec, Sec, _uSec})). +-spec rfc3339_to_system_time(DateTimeString) -> integer() when + DateTimeString :: rfc3339_string(). + +rfc3339_to_system_time(DateTimeString) -> + rfc3339_to_system_time(DateTimeString, []). + +-spec rfc3339_to_system_time(DateTimeString, Options) -> integer() when + DateTimeString :: rfc3339_string(), + Options :: [Option], + Option :: {'unit', rfc3339_time_unit()}. + +rfc3339_to_system_time(DateTimeString, Options) -> + Unit = proplists:get_value(unit, Options, second), + %% _T is the character separating the date and the time: + {DateStr, [_T|TimeStr]} = lists:split(10, DateTimeString), + {TimeStr2, TimeStr3} = lists:split(8, TimeStr), + {ok, [Hour, Min, Sec], []} = io_lib:fread("~d:~d:~d", TimeStr2), + {ok, [Year, Month, Day], []} = io_lib:fread("~d-~d-~d", DateStr), + DateTime = {{Year, Month, Day}, {Hour, Min, Sec}}, + IsFractionChar = fun(C) -> C >= $0 andalso C =< $9 orelse C =:= $. end, + {FractionStr, UtcOffset} = lists:splitwith(IsFractionChar, TimeStr3), + Time = datetime_to_system_time(DateTime), + Secs = Time - offset_adjustment(Time, second, UtcOffset), + check(DateTimeString, Options, Secs), + ScaledEpoch = erlang:convert_time_unit(Secs, second, Unit), + ScaledEpoch + copy_sign(fraction(Unit, FractionStr), ScaledEpoch). + %% seconds_to_daystime(Secs) = {Days, {Hour, Minute, Second}} @@ -363,6 +405,55 @@ seconds_to_time(Secs) when Secs >= 0, Secs < ?SECONDS_PER_DAY -> Second = Secs1 rem ?SECONDS_PER_MINUTE, {Hour, Minute, Second}. +-spec system_time_to_local_time(Time, TimeUnit) -> datetime() when + Time :: integer(), + TimeUnit :: erlang:time_unit(). + +system_time_to_local_time(Time, TimeUnit) -> + UniversalDate = system_time_to_universal_time(Time, TimeUnit), + erlang:universaltime_to_localtime(UniversalDate). + +-spec system_time_to_universal_time(Time, TimeUnit) -> datetime() when + Time :: integer(), + TimeUnit :: erlang:time_unit(). + +system_time_to_universal_time(Time, TimeUnit) -> + Secs = erlang:convert_time_unit(Time, TimeUnit, second), + system_time_to_datetime(Secs). + +-spec system_time_to_rfc3339(Time) -> DateTimeString when + Time :: integer(), + DateTimeString :: rfc3339_string(). + +system_time_to_rfc3339(Time) -> + system_time_to_rfc3339(Time, []). + +-type offset() :: [byte()] | (Time :: integer()). +-spec system_time_to_rfc3339(Time, Options) -> DateTimeString when + Time :: integer(), % Since Epoch + Options :: [Option], + Option :: {'offset', offset()} + | {'time_designator', byte()} + | {'unit', rfc3339_time_unit()}, + DateTimeString :: rfc3339_string(). + +system_time_to_rfc3339(Time, Options) -> + Unit = proplists:get_value(unit, Options, second), + OffsetOption = proplists:get_value(offset, Options, ""), + T = proplists:get_value(time_designator, Options, $T), + AdjustmentSecs = offset_adjustment(Time, Unit, OffsetOption), + Offset = offset(OffsetOption, AdjustmentSecs), + Adjustment = erlang:convert_time_unit(AdjustmentSecs, second, Unit), + AdjustedTime = Time + Adjustment, + Factor = factor(Unit), + Secs = AdjustedTime div Factor, + check(Time, Options, Secs), + DateTime = system_time_to_datetime(Secs), + {{Year, Month, Day}, {Hour, Min, Sec}} = DateTime, + FractionStr = fraction_str(Factor, AdjustedTime), + flat_fwrite("~4.10.0B-~2.10.0B-~2.10.0B~c~2.10.0B:~2.10.0B:~2.10.0B~s~s", + [Year, Month, Day, T, Hour, Min, Sec, FractionStr, Offset]). + %% time_difference(T1, T2) = Tdiff %% %% Returns the difference between two {Date, Time} structures. @@ -550,3 +641,85 @@ df(Year, _) -> true -> 1; false -> 0 end. + +check(_Arg, _Options, Secs) when Secs >= - ?SECONDS_FROM_0_TO_1970, + Secs < ?SECONDS_FROM_0_TO_10000 -> + ok; +check(Arg, Options, _Secs) -> + erlang:error({badarg, [Arg, Options]}). + +datetime_to_system_time(DateTime) -> + datetime_to_gregorian_seconds(DateTime) - ?SECONDS_FROM_0_TO_1970. + +system_time_to_datetime(Seconds) -> + gregorian_seconds_to_datetime(Seconds + ?SECONDS_FROM_0_TO_1970). + +offset(OffsetOption, Secs0) when OffsetOption =:= ""; + is_integer(OffsetOption) -> + Sign = case Secs0 < 0 of + true -> $-; + false -> $+ + end, + Secs = abs(Secs0), + Hour = Secs div 3600, + Min = (Secs rem 3600) div 60, + io_lib:fwrite("~c~2.10.0B:~2.10.0B", [Sign, Hour, Min]); +offset(OffsetOption, _Secs) -> + OffsetOption. + +offset_adjustment(Time, Unit, OffsetString) when is_list(OffsetString) -> + offset_string_adjustment(Time, Unit, OffsetString); +offset_adjustment(_Time, Unit, Offset) when is_integer(Offset) -> + erlang:convert_time_unit(Offset, Unit, second). + +offset_string_adjustment(Time, Unit, "") -> + local_offset(Time, Unit); +offset_string_adjustment(_Time, _Unit, "Z") -> + 0; +offset_string_adjustment(_Time, _Unit, "z") -> + 0; +offset_string_adjustment(_Time, _Unit, [Sign|Tz]) -> + {ok, [Hour, Min], []} = io_lib:fread("~d:~d", Tz), + Adjustment = 3600 * Hour + 60 * Min, + case Sign of + $- -> -Adjustment; + $+ -> Adjustment + end. + +local_offset(SystemTime, Unit) -> + LocalTime = system_time_to_local_time(SystemTime, Unit), + UniversalTime = system_time_to_universal_time(SystemTime, Unit), + LocalSecs = datetime_to_gregorian_seconds(LocalTime), + UniversalSecs = datetime_to_gregorian_seconds(UniversalTime), + LocalSecs - UniversalSecs. + +fraction_str(Factor, Time) -> + case Time rem Factor of + 0 -> + ""; + Fraction -> + FS = io_lib:fwrite(".~*..0B", [log10(Factor), abs(Fraction)]), + string:trim(FS, trailing, "0") + end. + +fraction(second, _) -> + 0; +fraction(_, "") -> + 0; +fraction(Unit, FractionStr) -> + round(factor(Unit) * list_to_float([$0|FractionStr])). + +copy_sign(N1, N2) when N2 < 0 -> -N1; +copy_sign(N1, _N2) -> N1. + +factor(second) -> 1; +factor(millisecond) -> 1000; +factor(microsecond) -> 1000000; +factor(nanosecond) -> 1000000000. + +log10(1000) -> 3; +log10(1000000) -> 6; +log10(1000000000) -> 9. + +flat_fwrite(F, S) -> + lists:flatten(io_lib:fwrite(F, S)). diff --git a/lib/stdlib/src/dets.erl b/lib/stdlib/src/dets.erl index 2d037ff795..0488c2bef2 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-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. @@ -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' | 'safe_fixed_monotonic_time' | 'size' | 'type' | 'version', + | 'safe_fixed' | 'safe_fixed_monotonic_time' | 'size' | 'type', Value :: term(). info(Tab, owner) -> @@ -620,12 +616,18 @@ next(Tab, Key) -> %% Assuming that a file already exists, open it with the %% parameters as already specified in the file itself. %% Return a ref leading to the file. -open_file(File) -> - case dets_server:open_file(to_list(File)) of - badarg -> % Should not happen. - erlang:error(dets_process_died, [File]); - Reply -> - einval(Reply, [File]) +open_file(File0) -> + File = to_list(File0), + case is_list(File) of + true -> + case dets_server:open_file(File) of + badarg -> % Should not happen. + erlang:error(dets_process_died, [File]); + Reply -> + einval(Reply, [File]) + end; + false -> + erlang:error(badarg, [File0]) end. -spec open_file(Name, Args) -> {'ok', Name} | {'error', Reason} when @@ -640,8 +642,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 +675,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 +1000,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 +1044,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 +1069,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 +1091,11 @@ 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. + true = is_list(Defaults#open_args.file), + is_comp_min_max(Defaults). to_list(T) when is_atom(T) -> atom_to_list(T); to_list(T) -> T. @@ -1129,7 +1124,6 @@ repl({file, File}, Defs) -> 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 +1139,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 +1157,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 +1280,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:Stacktrace -> + bug_found(no_name, Op, Bad, Stacktrace, 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 +1359,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. @@ -1368,29 +1376,8 @@ do_apply_op(Op, From, Head, N) -> catch 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, + _:Bad:Stacktrace -> + bug_found(Head#head.name, Op, Bad, Stacktrace, From), open_file_loop(Head, N) end. @@ -1398,10 +1385,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 +1393,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 +1408,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 +1448,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 +1485,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 +1506,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 +1516,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 +1531,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 +1571,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 +1586,40 @@ apply_op(Op, From, Head, N) -> ok end. +bug_found(Name, Op, Bad, Stacktrace, 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, 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 +1627,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 +1737,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 +1770,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 +1798,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 +1831,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 +1840,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 +1882,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 +1900,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)} @@ -2057,7 +2037,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 -> @@ -2090,7 +2070,7 @@ 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) -> @@ -2117,7 +2097,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) -> @@ -2126,8 +2106,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. @@ -2144,7 +2122,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; @@ -2162,7 +2140,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. @@ -2196,7 +2174,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 @@ -2209,9 +2187,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 -> @@ -2220,7 +2199,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 -> @@ -2228,10 +2207,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} -> @@ -2287,7 +2266,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} @@ -2367,7 +2347,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), @@ -2395,7 +2375,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, []), @@ -2444,18 +2424,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}} -> @@ -2466,7 +2436,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. @@ -2480,7 +2450,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))} @@ -2508,11 +2478,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 ..."} @@ -2526,8 +2495,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 -> @@ -2560,33 +2528,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}; @@ -2595,17 +2553,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 ..."} @@ -2633,23 +2587,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 -> @@ -2663,8 +2614,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}. @@ -2673,7 +2624,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 @@ -2681,20 +2632,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}); @@ -2709,15 +2651,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 @@ -2730,15 +2670,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, @@ -2749,7 +2681,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} -> @@ -2784,7 +2716,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, @@ -2797,10 +2729,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}}; @@ -2819,7 +2751,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, @@ -2828,7 +2760,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 @@ -2878,10 +2810,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} -> @@ -2896,14 +2827,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}])), @@ -2944,13 +2874,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; @@ -2965,13 +2888,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); @@ -2990,7 +2906,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) -> @@ -3040,7 +2956,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; @@ -3053,13 +2969,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. @@ -3100,7 +3012,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, []}; @@ -3185,7 +3097,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}. @@ -3216,7 +3128,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 @@ -3238,7 +3150,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} -> @@ -3282,7 +3194,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 @@ -3295,7 +3207,7 @@ time_now() -> make_timestamp(MonTime, TimeOffset) -> ErlangSystemTime = erlang:convert_time_unit(MonTime+TimeOffset, native, - micro_seconds), + microsecond), MegaSecs = ErlangSystemTime div 1000000000000, Secs = ErlangSystemTime div 1000000 - MegaSecs*1000000, MicroSecs = ErlangSystemTime rem 1000000, @@ -3307,7 +3219,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. @@ -3322,15 +3234,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 34a8ddddaa..12394bd1ad 100644 --- a/lib/stdlib/src/dets_utils.erl +++ b/lib/stdlib/src/dets_utils.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2001-2016. All Rights Reserved. +%% Copyright Ericsson AB 2001-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. @@ -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 -> @@ -385,7 +377,8 @@ corrupt_reason(Head, Reason0) -> no_disk_map -> Reason0; DM -> - ST = erlang:get_stacktrace(), + {current_stacktrace, ST} = + erlang:process_info(self(), current_stacktrace), PD = get(), {Reason0, ST, PD, DM} end, @@ -395,7 +388,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 +471,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. diff --git a/lib/stdlib/src/dets_v8.erl b/lib/stdlib/src/dets_v8.erl deleted file mode 100644 index 1bf53d91b1..0000000000 --- a/lib/stdlib/src/dets_v8.erl +++ /dev/null @@ -1,1594 +0,0 @@ -%% -%% %CopyrightBegin% -%% -%% 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. -%% 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]). - --dialyzer(no_improper_lists). - --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 6c406fc03a..3ab8f87ebf 100644 --- a/lib/stdlib/src/dets_v9.erl +++ b/lib/stdlib/src/dets_v9.erl @@ -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]). @@ -228,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. @@ -249,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)). @@ -364,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, @@ -457,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). @@ -510,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 = @@ -534,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, @@ -563,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. @@ -621,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) -> @@ -678,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. @@ -686,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 @@ -747,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. @@ -1245,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), @@ -1257,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) -> @@ -1461,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 @@ -1485,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)} @@ -1496,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, _} -> @@ -1564,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]); @@ -1607,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) @@ -1794,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 f921e28ef6..9449ba3dc2 100644 --- a/lib/stdlib/src/dict.erl +++ b/lib/stdlib/src/dict.erl @@ -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). 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 0e9c457de2..f027d05f55 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-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. @@ -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. @@ -279,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 @@ -299,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], @@ -314,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], @@ -328,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) -> @@ -361,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), @@ -381,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]}; @@ -389,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), @@ -400,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) -> @@ -436,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); @@ -445,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) -> @@ -454,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}. @@ -465,6 +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([_|_]) -> true; %% Is grapheme word_char(_) -> false. %% over_white(Chars, InitialStack, InitialCount) -> @@ -488,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]) -> @@ -518,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. @@ -529,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, $)}; @@ -553,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. @@ -574,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..181a524db6 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. @@ -38,18 +38,28 @@ -type epp_handle() :: pid(). -type source_encoding() :: latin1 | utf8. --type ifdef() :: 'ifdef' | 'ifndef' | 'else'. +-type ifdef() :: 'ifdef' | 'ifndef' | 'if' | '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) @@ -113,6 +117,7 @@ open(Name, File, StartLocation, Path, Pdm) -> {'ok', Epp} | {'ok', Epp, Extra} | {'error', ErrorDescriptor} when Options :: [{'default_encoding', DefEncoding :: source_encoding()} | {'includes', IncludePath :: [DirectoryName :: file:name()]} | + {'source_name', SourceName :: file:name()} | {'macros', PredefMacros :: macros()} | {'name',FileName :: file:name()} | 'extra'], @@ -156,11 +161,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 +195,41 @@ 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(elif_after_else) -> + "'elif' following 'else'"; 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) -> @@ -232,6 +249,7 @@ parse_file(Ifile, Path, Predefs) -> {'ok', [Form]} | {'ok', [Form], Extra} | {error, OpenError} when FileName :: file:name(), Options :: [{'includes', IncludePath :: [DirectoryName :: file:name()]} | + {'source_name', SourceName :: file:name()} | {'macros', PredefMacros :: macros()} | {'default_encoding', DefEncoding :: source_encoding()} | 'extra'], @@ -257,31 +275,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(). @@ -474,7 +483,7 @@ com_enc(_B, _Fun, _N, L, Ps) -> com_enc_end([L | Ps]). com_enc_end(Ps0) -> - Ps = lists:reverse([lists:reverse(string:to_lower(P)) || P <- Ps0]), + Ps = lists:reverse([lists:reverse(lowercase(P)) || P <- Ps0]), com_encoding(Ps). com_encoding(["latin","1"|_]) -> @@ -484,6 +493,9 @@ com_encoding(["utf","8"|_]) -> com_encoding(_) -> throw(no). % Don't try any further +lowercase(S) -> + unicode:characters_to_list(string:lowercase(S)). + normalize_typed_record_fields([]) -> {typed, []}; normalize_typed_record_fields(Fields) -> @@ -530,9 +542,10 @@ server(Pid, Name, Options, #epp{pre_opened=PreOpened}=St) -> init_server(Pid, Name, Options, St) end. -init_server(Pid, Name, Options, St0) -> +init_server(Pid, FileName, Options, St0) -> + SourceName = proplists:get_value(source_name, Options, FileName), Pdm = proplists:get_value(macros, Options, []), - Ms0 = predef_macros(Name), + Ms0 = predef_macros(FileName), case user_predef(Pdm, Ms0) of {ok,Ms1} -> #epp{file = File, location = AtLocation} = St0, @@ -542,14 +555,15 @@ init_server(Pid, Name, Options, St0) -> epp_reply(Pid, {ok,self(),Encoding}), %% ensure directory of current source file is %% first in path - Path = [filename:dirname(Name) | + Path = [filename:dirname(FileName) | proplists:get_value(includes, Options, [])], - St = St0#epp{delta=0, name=Name, name2=Name, + St = St0#epp{delta=0, name=SourceName, name2=SourceName, path=Path, macs=Ms1, 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(SourceName), Anno, + AtLocation, code), wait_req_scan(St); {error,E} -> epp_reply(Pid, {error,E}) @@ -560,18 +574,22 @@ 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(), + OtpVersion = list_to_integer(erlang:system_info(otp_release)), + 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}]}}, + {'OTP_RELEASE', {none,[{integer,Anno,OtpVersion}]}} + ], + maps:from_list(Defs). %% user_predef(PreDefMacros, Macros) -> %% {ok,MacroDict} | {error,E} @@ -580,28 +598,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 +626,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 +680,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 +702,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 +733,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 +774,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 +795,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 +803,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 +813,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 +880,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 +912,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 +940,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 +964,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 +981,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 +1020,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 +1036,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 +1054,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) -> @@ -1062,21 +1092,118 @@ scan_else(_Toks, Else, From, St) -> epp_reply(From, {error,{loc(Else),epp,{bad,'else'}}}), wait_req_scan(St). -%% scan_if(Tokens, EndifToken, From, EppState) +%% scan_if(Tokens, IfToken, From, EppState) %% Handle the conditional parsing of a file. -%% Report a badly formed if test and then treat as false macro. +scan_if([{'(',_}|_]=Toks, If, From, St) -> + try eval_if(Toks, St) of + true -> + scan_toks(From, St#epp{istk=['if'|St#epp.istk]}); + _ -> + skip_toks(From, St, ['if']) + catch + throw:Error0 -> + Error = case Error0 of + {_,erl_parse,_} -> + {error,Error0}; + _ -> + {error,{loc(If),epp,Error0}} + end, + epp_reply(From, Error), + wait_req_skip(St, ['if']) + end; scan_if(_Toks, If, From, St) -> - epp_reply(From, {error,{loc(If),epp,{'NYI','if'}}}), + epp_reply(From, {error,{loc(If),epp,{bad,'if'}}}), wait_req_skip(St, ['if']). +eval_if(Toks0, St) -> + Toks = expand_macros(Toks0, St), + Es1 = case erl_parse:parse_exprs(Toks) of + {ok,Es0} -> Es0; + {error,E} -> throw(E) + end, + Es = rewrite_expr(Es1, St), + assert_guard_expr(Es), + Bs = erl_eval:new_bindings(), + LocalFun = fun(_Name, _Args) -> + error(badarg) + end, + try erl_eval:exprs(Es, Bs, {value,LocalFun}) of + {value,Res,_} -> + Res + catch + _:_ -> + false + end. + +assert_guard_expr([E0]) -> + E = rewrite_expr(E0, none), + case erl_lint:is_guard_expr(E) of + false -> + throw({bad,'if'}); + true -> + ok + end; +assert_guard_expr(_) -> + throw({bad,'if'}). + +%% Dual-purpose rewriting function. When the second argument is +%% an #epp{} record, calls to defined(Symbol) will be evaluated. +%% When the second argument is 'none', legal calls to our built-in +%% functions are eliminated in order to turn the expression into +%% a legal guard expression. + +rewrite_expr({call,_,{atom,_,defined},[N0]}, #epp{macs=Macs}) -> + %% Evaluate defined(Symbol). + N = case N0 of + {var,_,N1} -> N1; + {atom,_,N1} -> N1; + _ -> throw({bad,'if'}) + end, + {atom,0,maps:is_key(N, Macs)}; +rewrite_expr({call,_,{atom,_,Name},As0}, none) -> + As = rewrite_expr(As0, none), + Arity = length(As), + case erl_internal:bif(Name, Arity) andalso + not erl_internal:guard_bif(Name, Arity) of + false -> + %% A guard BIF, an -if built-in, or an unknown function. + %% Eliminate the call so that erl_lint will not complain. + %% The call might fail later at evaluation time. + to_conses(As); + true -> + %% An auto-imported BIF (not guard BIF). Not allowed. + throw({bad,'if'}) + end; +rewrite_expr([H|T], St) -> + [rewrite_expr(H, St)|rewrite_expr(T, St)]; +rewrite_expr(Tuple, St) when is_tuple(Tuple) -> + list_to_tuple(rewrite_expr(tuple_to_list(Tuple), St)); +rewrite_expr(Other, _) -> + Other. + +to_conses([H|T]) -> + {cons,0,H,to_conses(T)}; +to_conses([]) -> + {nil,0}. + %% scan_elif(Tokens, EndifToken, From, EppState) %% Handle the conditional parsing of a file. %% Report a badly formed if test and then treat as false macro. scan_elif(_Toks, Elif, From, St) -> - epp_reply(From, {error,{loc(Elif),epp,{'NYI','elif'}}}), - wait_req_scan(St). + case St#epp.istk of + ['else'|Cis] -> + epp_reply(From, {error,{loc(Elif), + epp,{illegal,"unbalanced",'elif'}}}), + wait_req_skip(St#epp{istk=Cis}, ['else']); + [_I|Cis] -> + skip_toks(From, St#epp{istk=Cis}, ['elif']); + [] -> + epp_reply(From, {error,{loc(Elif),epp, + {illegal,"unbalanced",elif}}}), + wait_req_scan(St) + end. %% scan_endif(Tokens, EndifToken, From, EppState) %% If we are in an if body then exit it, else report an error. @@ -1098,16 +1225,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). @@ -1130,6 +1262,8 @@ skip_toks(From, St, [I|Sis]) -> skip_toks(From, St#epp{location=Cl}, ['if',I|Sis]); {ok,[{'-',_Lh},{atom,_Le,'else'}=Else|_Toks],Cl}-> skip_else(Else, From, St#epp{location=Cl}, [I|Sis]); + {ok,[{'-',_Lh},{atom,_Le,'elif'}=Elif|Toks],Cl}-> + skip_elif(Toks, Elif, From, St#epp{location=Cl}, [I|Sis]); {ok,[{'-',_Lh},{atom,_Le,endif}|_Toks],Cl} -> skip_toks(From, St#epp{location=Cl}, Sis); {ok,_Toks,Cl} -> @@ -1160,70 +1294,82 @@ skip_toks(From, St, []) -> skip_else(Else, From, St, ['else'|Sis]) -> epp_reply(From, {error,{loc(Else),epp,{illegal,"repeated",'else'}}}), wait_req_skip(St, ['else'|Sis]); +skip_else(_Else, From, St, ['elif'|Sis]) -> + skip_toks(From, St, ['else'|Sis]); skip_else(_Else, From, St, [_I]) -> scan_toks(From, St#epp{istk=['else'|St#epp.istk]}); skip_else(_Else, From, St, Sis) -> skip_toks(From, St, Sis). +skip_elif(_Toks, Elif, From, St, ['else'|_]=Sis) -> + epp_reply(From, {error,{loc(Elif),epp,elif_after_else}}), + wait_req_skip(St, Sis); +skip_elif(Toks, Elif, From, St, [_I]) -> + scan_if(Toks, Elif, From, St); +skip_elif(_Toks, _Elif, From, St, Sis) -> + skip_toks(From, St, Sis). + %% macro_pars(Tokens, ArgStack) %% 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 - throw({error,Lm,{undefined,M,Arity}}); - {ok, undefined} -> %% Predefined macro without definition + case Ms of + #{M:=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 +1377,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 +1386,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 +1457,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 +1530,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 +1554,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 +1668,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..f781312ca2 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,13 +181,15 @@ 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) -> {[makedep,{makedep_output,standard_io}],T}; parse_dep_option("D", T) -> {[makedep],T}; +parse_dep_option("MD", T) -> + {[makedep_side_effect],T}; parse_dep_option("F"++Opt, T0) -> {File,T} = get_option("MF", Opt, T0), {[makedep,{makedep_output,File}],T}; @@ -201,7 +204,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() -> @@ -220,6 +223,7 @@ usage() -> "the dependencies"}, {"-MP","add a phony target for each dependency"}, {"-MD","same as -M -MT file (with default 'file')"}, + {"-MMD","generate dependencies as a side-effect"}, {"-o name","name output directory or file"}, {"-pa path","add path to the front of Erlang's code path"}, {"-pz path","add path to the end of Erlang's code path"}, @@ -336,7 +340,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/lib.erl b/lib/stdlib/src/erl_error.erl index eb24516c50..fdcb9e824c 100644 --- a/lib/stdlib/src/lib.erl +++ b/lib/stdlib/src/erl_error.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. @@ -17,115 +17,11 @@ %% %% %CopyrightEnd% %% --module(lib). - --export([flush_receive/0, error_message/2, progname/0, nonl/1, send/2, - sendw/2, eval_str/1]). +-module(erl_error). -export([format_exception/6, format_exception/7, format_stacktrace/4, format_stacktrace/5, - format_call/4, format_call/5, format_fun/1]). - --spec flush_receive() -> 'ok'. - -flush_receive() -> - receive - _Any -> - flush_receive() - after - 0 -> - ok - end. - -%% -%% Functions for doing standard system format i/o. -%% --spec error_message(Format, Args) -> 'ok' when - Format :: io:format(), - Args :: [term()]. - -error_message(Format, Args) -> - io:format(<<"** ~ts **\n">>, [io_lib:format(Format, Args)]). - -%% Return the name of the script that starts (this) erlang -%% --spec progname() -> atom(). - -progname() -> - case init:get_argument(progname) of - {ok, [[Prog]]} -> - list_to_atom(Prog); - _Other -> - no_prog_name - end. - --spec nonl(String1) -> String2 when - String1 :: string(), - String2 :: string(). - -nonl([10]) -> []; -nonl([]) -> []; -nonl([H|T]) -> [H|nonl(T)]. - --spec send(To, Msg) -> Msg when - To :: pid() | atom() | {atom(), node()}, - Msg :: term(). - -send(To, Msg) -> To ! Msg. - --spec sendw(To, Msg) -> Msg when - To :: pid() | atom() | {atom(), node()}, - Msg :: term(). - -sendw(To, Msg) -> - To ! {self(), Msg}, - receive - Reply -> Reply - end. - -%% eval_str(InStr) -> {ok, OutStr} | {error, ErrStr'} -%% InStr must represent a body -%% Note: If InStr is a binary it has to be a Latin-1 string. -%% If you have a UTF-8 encoded binary you have to call -%% unicode:characters_to_list/1 before the call to eval_str(). - --define(result(F,D), lists:flatten(io_lib:format(F, D))). - --spec eval_str(string() | unicode:latin1_binary()) -> - {'ok', string()} | {'error', string()}. - -eval_str(Str) when is_list(Str) -> - case erl_scan:tokens([], Str, 0) of - {more, _} -> - {error, "Incomplete form (missing .<cr>)??"}; - {done, {ok, Toks, _}, Rest} -> - case all_white(Rest) of - true -> - case erl_parse:parse_exprs(Toks) of - {ok, Exprs} -> - case catch erl_eval:exprs(Exprs, erl_eval:new_bindings()) of - {value, Val, _} -> - {ok, Val}; - Other -> - {error, ?result("*** eval: ~p", [Other])} - end; - {error, {_Line, Mod, Args}} -> - Msg = ?result("*** ~ts",[Mod:format_error(Args)]), - {error, Msg} - end; - false -> - {error, ?result("Non-white space found after " - "end-of-form :~ts", [Rest])} - end - end; -eval_str(Bin) when is_binary(Bin) -> - eval_str(binary_to_list(Bin)). - -all_white([$\s|T]) -> all_white(T); -all_white([$\n|T]) -> all_white(T); -all_white([$\t|T]) -> all_white(T); -all_white([]) -> true; -all_white(_) -> false. + format_call/4, format_call/5, format_fun/1, format_fun/2]). %%% Formatting of exceptions, mfa:s and funs. @@ -179,7 +75,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 +89,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 +133,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 +168,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 +226,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 +248,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 +275,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 -> @@ -419,7 +321,7 @@ pp_arguments(PF, As, I, Enc) -> Ll = length(L), A = list_to_atom(lists:duplicate(Ll, $a)), S0 = unicode:characters_to_list(PF([A | T], I+1), Enc), - brackets_to_parens([$[,L,string:sub_string(S0, 2+Ll)], Enc); + brackets_to_parens([$[,L,string:slice(S0, 1+Ll)], Enc); _ -> brackets_to_parens(PF(As, I+1), Enc) end. @@ -435,10 +337,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 +351,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 +408,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/erl_eval.erl b/lib/stdlib/src/erl_eval.erl index 40a34aa30f..2066b2f60f 100644 --- a/lib/stdlib/src/erl_eval.erl +++ b/lib/stdlib/src/erl_eval.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2016. 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. @@ -27,8 +27,9 @@ -export([exprs/2,exprs/3,exprs/4,expr/2,expr/3,expr/4,expr/5, expr_list/2,expr_list/3,expr_list/4]). -export([new_bindings/0,bindings/1,binding/2,add_binding/3,del_binding/2]). - --export([is_constant_expr/1, partial_eval/1]). +-export([extended_parse_exprs/1, extended_parse_term/1, + subst_values_for_vars/2]). +-export([is_constant_expr/1, partial_eval/1, eval_str/1]). %% Is used by standalone Erlang (escript). %% Also used by shell.erl. @@ -69,6 +70,9 @@ -type(non_local_function_handler() :: {value, nlfun_handler()} | none). +-define(STACKTRACE, + element(2, erlang:process_info(self(), current_stacktrace))). + %% exprs(ExpressionSeq, Bindings) %% exprs(ExpressionSeq, Bindings, LocalFuncHandler) %% exprs(ExpressionSeq, Bindings, LocalFuncHandler, ExternalFuncHandler) @@ -90,7 +94,7 @@ exprs(Exprs, Bs) -> ok -> exprs(Exprs, Bs, none, none, none); {error,{_Line,_Mod,Error}} -> - erlang:raise(error, Error, [{?MODULE,exprs,2}]) + erlang:raise(error, Error, ?STACKTRACE) end. -spec(exprs(Expressions, Bindings, LocalFunctionHandler) -> @@ -141,7 +145,7 @@ expr(E, Bs) -> ok -> expr(E, Bs, none, none, none); {error,{_Line,_Mod,Error}} -> - erlang:raise(error, Error, [{?MODULE,expr,2}]) + erlang:raise(error, Error, ?STACKTRACE) end. -spec(expr(Expression, Bindings, LocalFunctionHandler) -> @@ -182,7 +186,7 @@ check_command(Es, Bs) -> fun_data(F) when is_function(F) -> case erlang:fun_info(F, module) of - {module,erl_eval} -> + {module,?MODULE} -> case erlang:fun_info(F, env) of {env,[{FBs,_FLf,_FEf,FCs}]} -> {fun_data,FBs,FCs}; @@ -209,8 +213,8 @@ expr({var,_,V}, Bs, _Lf, _Ef, RBs) -> case binding(V, Bs) of {value,Val} -> ret_expr(Val, Bs, RBs); - unbound -> % Should not happen. - erlang:raise(error, {unbound,V}, stacktrace()) + unbound -> % Cannot not happen if checked by erl_lint + erlang:raise(error, {unbound,V}, ?STACKTRACE) end; expr({char,_,C}, Bs, _Lf, _Ef, RBs) -> ret_expr(C, Bs, RBs); @@ -236,13 +240,13 @@ expr({tuple,_,Es}, Bs0, Lf, Ef, RBs) -> {Vs,Bs} = expr_list(Es, Bs0, Lf, Ef), ret_expr(list_to_tuple(Vs), Bs, RBs); expr({record_field,_,_,Name,_}, _Bs, _Lf, _Ef, _RBs) -> - erlang:raise(error, {undef_record,Name}, stacktrace()); + erlang:raise(error, {undef_record,Name}, ?STACKTRACE); expr({record_index,_,Name,_}, _Bs, _Lf, _Ef, _RBs) -> - erlang:raise(error, {undef_record,Name}, stacktrace()); + erlang:raise(error, {undef_record,Name}, ?STACKTRACE); expr({record,_,Name,_}, _Bs, _Lf, _Ef, _RBs) -> - erlang:raise(error, {undef_record,Name}, stacktrace()); + erlang:raise(error, {undef_record,Name}, ?STACKTRACE); expr({record,_,_,Name,_}, _Bs, _Lf, _Ef, _RBs) -> - erlang:raise(error, {undef_record,Name}, stacktrace()); + erlang:raise(error, {undef_record,Name}, ?STACKTRACE); %% map expr({map,_,Binding,Es}, Bs0, Lf, Ef, RBs) -> @@ -281,7 +285,7 @@ expr({'fun',_Line,{function,Mod0,Name0,Arity0}}, Bs0, Lf, Ef, RBs) -> ret_expr(F, Bs, RBs); expr({'fun',_Line,{function,Name,Arity}}, _Bs0, _Lf, _Ef, _RBs) -> % R8 %% Don't know what to do... - erlang:raise(error, undef, [{erl_eval,Name,Arity}|stacktrace()]); + erlang:raise(error, undef, [{?MODULE,Name,Arity}|?STACKTRACE]); expr({'fun',Line,{clauses,Cs}} = Ex, Bs, Lf, Ef, RBs) -> %% Save only used variables in the function environment. %% {value,L,V} are hidden while lint finds used variables. @@ -325,8 +329,9 @@ expr({'fun',Line,{clauses,Cs}} = Ex, Bs, Lf, Ef, RBs) -> 20 -> fun (A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T) -> eval_fun([A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T], Info) end; _Other -> - erlang:raise(error, {'argument_limit',{'fun',Line,Cs}}, - stacktrace()) + L = erl_anno:location(Line), + erlang:raise(error, {'argument_limit',{'fun',L,to_terms(Cs)}}, + ?STACKTRACE) end, ret_expr(F, Bs, RBs); expr({named_fun,Line,Name,Cs} = Ex, Bs, Lf, Ef, RBs) -> @@ -377,8 +382,10 @@ expr({named_fun,Line,Name,Cs} = Ex, Bs, Lf, Ef, RBs) -> eval_named_fun([A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T], RF, Info) end; _Other -> - erlang:raise(error, {'argument_limit',{named_fun,Line,Name,Cs}}, - stacktrace()) + L = erl_anno:location(Line), + erlang:raise(error, {'argument_limit', + {named_fun,L,Name,to_terms(Cs)}}, + ?STACKTRACE) end, ret_expr(F, Bs, RBs); expr({call,_,{remote,_,{atom,_,qlc},{atom,_,q}},[{lc,_,_E,_Qs}=LC | As0]}, @@ -422,25 +429,28 @@ expr({call,_,Func0,As0}, Bs0, Lf, Ef, RBs) -> % function or {Mod,Fun} {As,Bs2} = expr_list(As0, Bs1, Lf, Ef), case Func of {M,F} when is_atom(M), is_atom(F) -> - erlang:raise(error, {badfun,Func}, stacktrace()); + erlang:raise(error, {badfun,Func}, ?STACKTRACE); _ -> do_apply(Func, As, Bs2, Ef, RBs) end; expr({'catch',_,Expr}, Bs0, Lf, Ef, RBs) -> - Ref = make_ref(), - case catch {Ref,expr(Expr, Bs0, Lf, Ef, none)} of - {Ref,{value,V,Bs}} -> % Nothing was thrown (guaranteed). - ret_expr(V, Bs, RBs); - Other -> - ret_expr(Other, Bs0, RBs) + try expr(Expr, Bs0, Lf, Ef, none) of + {value,V,Bs} -> + ret_expr(V, Bs, RBs) + catch + throw:Term -> + ret_expr(Term, Bs0, RBs); + exit:Reason -> + ret_expr({'EXIT',Reason}, Bs0, RBs); + error:Reason:Stacktrace -> + ret_expr({'EXIT',{Reason,Stacktrace}}, Bs0, RBs) end; expr({match,_,Lhs,Rhs0}, Bs0, Lf, Ef, RBs) -> {value,Rhs,Bs1} = expr(Rhs0, Bs0, Lf, Ef, none), case match(Lhs, Rhs, Bs1) of {match,Bs} -> ret_expr(Rhs, Bs, RBs); - nomatch -> - erlang:raise(error, {badmatch,Rhs}, stacktrace()) + nomatch -> erlang:raise(error, {badmatch,Rhs}, ?STACKTRACE) end; expr({op,_,Op,A0}, Bs0, Lf, Ef, RBs) -> {value,A,Bs} = expr(A0, Bs0, Lf, Ef, none), @@ -452,7 +462,7 @@ expr({op,_,'andalso',L0,R0}, Bs0, Lf, Ef, RBs) -> {value,R,_} = expr(R0, Bs1, Lf, Ef, none), R; false -> false; - _ -> erlang:raise(error, {badarg,L}, stacktrace()) + _ -> erlang:raise(error, {badarg,L}, ?STACKTRACE) end, ret_expr(V, Bs1, RBs); expr({op,_,'orelse',L0,R0}, Bs0, Lf, Ef, RBs) -> @@ -462,7 +472,7 @@ expr({op,_,'orelse',L0,R0}, Bs0, Lf, Ef, RBs) -> false -> {value,R,_} = expr(R0, Bs1, Lf, Ef, none), R; - _ -> erlang:raise(error, {badarg,L}, stacktrace()) + _ -> erlang:raise(error, {badarg,L}, ?STACKTRACE) end, ret_expr(V, Bs1, RBs); expr({op,_,Op,L0,R0}, Bs0, Lf, Ef, RBs) -> @@ -474,7 +484,7 @@ expr({bin,_,Fs}, Bs0, Lf, Ef, RBs) -> {value,V,Bs} = eval_bits:expr_grp(Fs, Bs0, EvalFun), ret_expr(V, Bs, RBs); expr({remote,_,_,_}, _Bs, _Lf, _Ef, _RBs) -> - erlang:raise(error, {badexpr,':'}, stacktrace()); + erlang:raise(error, {badexpr,':'}, ?STACKTRACE); expr({value,_,Val}, Bs, _Lf, _Ef, RBs) -> % Special case straight values. ret_expr(Val, Bs, RBs). @@ -570,7 +580,7 @@ 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, _Ef, _RBs) -> - erlang:raise(error, undef, [{erl_eval,Func,length(As0)}|stacktrace()]). + erlang:raise(error, undef, [{?MODULE,Func,length(As0)}|?STACKTRACE]). local_func2({value,V,Bs}, RBs) -> ret_expr(V, Bs, RBs); @@ -637,7 +647,7 @@ do_apply(Func, As, Bs0, Ef, RBs) -> {{arity, Arity}, Arity} -> eval_fun(FCs, As, FBs, FLf, FEf, NRBs); _ -> - erlang:raise(error, {badarity,{Func,As}},stacktrace()) + erlang:raise(error, {badarity,{Func,As}},?STACKTRACE) end; {{env,[{FBs,FLf,FEf,FCs,FName}]},_} -> NRBs = if @@ -648,7 +658,7 @@ do_apply(Func, As, Bs0, Ef, RBs) -> {{arity, Arity}, Arity} -> eval_named_fun(FCs, As, FBs, FLf, FEf, FName, Func, NRBs); _ -> - erlang:raise(error, {badarity,{Func,As}},stacktrace()) + erlang:raise(error, {badarity,{Func,As}},?STACKTRACE) end; {no_env,none} when RBs =:= value -> %% Make tail recursive calls when possible. @@ -730,7 +740,7 @@ eval_generate([V|Rest], P, Bs0, Lf, Ef, CompFun, Acc) -> eval_generate([], _P, _Bs0, _Lf, _Ef, _CompFun, Acc) -> Acc; eval_generate(Term, _P, _Bs0, _Lf, _Ef, _CompFun, _Acc) -> - erlang:raise(error, {bad_generator,Term}, stacktrace()). + erlang:raise(error, {bad_generator,Term}, ?STACKTRACE). eval_b_generate(<<_/bitstring>>=Bin, P, Bs0, Lf, Ef, CompFun, Acc) -> Mfun = match_fun(Bs0), @@ -746,7 +756,7 @@ eval_b_generate(<<_/bitstring>>=Bin, P, Bs0, Lf, Ef, CompFun, Acc) -> Acc end; eval_b_generate(Term, _P, _Bs0, _Lf, _Ef, _CompFun, _Acc) -> - erlang:raise(error, {bad_generator,Term}, stacktrace()). + erlang:raise(error, {bad_generator,Term}, ?STACKTRACE). eval_filter(F, Bs0, Lf, Ef, CompFun, Acc) -> case erl_lint:is_guard_test(F) of @@ -760,7 +770,7 @@ eval_filter(F, Bs0, Lf, Ef, CompFun, Acc) -> {value,true,Bs1} -> CompFun(Bs1); {value,false,_} -> Acc; {value,V,_} -> - erlang:raise(error, {bad_filter,V}, stacktrace()) + erlang:raise(error, {bad_filter,V}, ?STACKTRACE) end end. @@ -816,7 +826,7 @@ eval_fun([{clause,_,H,G,B}|Cs], As, Bs0, Lf, Ef, RBs) -> end; eval_fun([], As, _Bs, _Lf, _Ef, _RBs) -> erlang:raise(error, function_clause, - [{?MODULE,'-inside-an-interpreted-fun-',As}|stacktrace()]). + [{?MODULE,'-inside-an-interpreted-fun-',As}|?STACKTRACE]). eval_named_fun(As, Fun, {Bs0,Lf,Ef,Cs,Name}) -> @@ -836,7 +846,7 @@ eval_named_fun([{clause,_,H,G,B}|Cs], As, Bs0, Lf, Ef, Name, Fun, RBs) -> end; eval_named_fun([], As, _Bs, _Lf, _Ef, _Name, _Fun, _RBs) -> erlang:raise(error, function_clause, - [{?MODULE,'-inside-an-interpreted-fun-',As}|stacktrace()]). + [{?MODULE,'-inside-an-interpreted-fun-',As}|?STACKTRACE]). %% expr_list(ExpressionList, Bindings) @@ -894,13 +904,13 @@ if_clauses([{clause,_,[],G,B}|Cs], Bs, Lf, Ef, RBs) -> false -> if_clauses(Cs, Bs, Lf, Ef, RBs) end; if_clauses([], _Bs, _Lf, _Ef, _RBs) -> - erlang:raise(error, if_clause, stacktrace()). + erlang:raise(error, if_clause, ?STACKTRACE). %% try_clauses(Body, CaseClauses, CatchClauses, AfterBody, Bindings, %% LocalFuncHandler, ExtFuncHandler, RBs) -%% When/if variable bindings between the different parts of a -%% try-catch expression are introduced this will have to be rewritten. + try_clauses(B, Cases, Catches, AB, Bs, Lf, Ef, RBs) -> + check_stacktrace_vars(Catches, Bs), try exprs(B, Bs, Lf, Ef, none) of {value,V,Bs1} when Cases =:= [] -> ret_expr(V, Bs1, RBs); @@ -909,23 +919,18 @@ try_clauses(B, Cases, Catches, AB, Bs, Lf, Ef, RBs) -> {B2,Bs2} -> exprs(B2, Bs2, Lf, Ef, RBs); nomatch -> - erlang:raise(error, {try_clause,V}, stacktrace()) + erlang:raise(error, {try_clause,V}, ?STACKTRACE) end catch - Class:Reason when Catches =:= [] -> - %% Rethrow - erlang:raise(Class, Reason, stacktrace()); - Class:Reason -> -%%% %% Set stacktrace -%%% try erlang:raise(Class, Reason, stacktrace()) -%%% catch _:_ -> ok -%%% end, - V = {Class,Reason,erlang:get_stacktrace()}, - case match_clause(Catches, [V],Bs, Lf, Ef) of + Class:Reason:Stacktrace when Catches =:= [] -> + erlang:raise(Class, Reason, Stacktrace); + Class:Reason:Stacktrace -> + V = {Class,Reason,Stacktrace}, + case match_clause(Catches, [V], Bs, Lf, Ef) of {B2,Bs2} -> exprs(B2, Bs2, Lf, Ef, RBs); nomatch -> - erlang:raise(Class, Reason, stacktrace()) + erlang:raise(Class, Reason, Stacktrace) end after if AB =:= [] -> @@ -935,6 +940,23 @@ try_clauses(B, Cases, Catches, AB, Bs, Lf, Ef, RBs) -> end end. +check_stacktrace_vars([{clause,_,[{tuple,_,[_,_,STV]}],_,_}|Cs], Bs) -> + case STV of + {var,_,V} -> + case binding(V, Bs) of + {value, _} -> + erlang:raise(error, stacktrace_bound, ?STACKTRACE); + unbound -> + check_stacktrace_vars(Cs, Bs) + end; + _ -> + erlang:raise(error, + {illegal_stacktrace_variable,STV}, + ?STACKTRACE) + end; +check_stacktrace_vars([], _Bs) -> + ok. + %% case_clauses(Value, Clauses, Bindings, LocalFuncHandler, ExtFuncHandler, %% RBs) @@ -943,7 +965,7 @@ case_clauses(Val, Cs, Bs, Lf, Ef, RBs) -> {B, Bs1} -> exprs(B, Bs1, Lf, Ef, RBs); nomatch -> - erlang:raise(error, {case_clause,Val}, stacktrace()) + erlang:raise(error, {case_clause,Val}, ?STACKTRACE) end. %% @@ -1018,7 +1040,7 @@ guard0([G|Gs], Bs0, Lf, Ef) -> {value,false,_} -> false end; false -> - erlang:raise(error, guard_expr, stacktrace()) + erlang:raise(error, guard_expr, ?STACKTRACE) end; guard0([], _Bs, _Lf, _Ef) -> true. @@ -1073,7 +1095,7 @@ match(Pat, Term, Bs) -> match(Pat, Term, Bs, BBs) -> case catch match1(Pat, Term, Bs, BBs) of invalid -> - erlang:raise(error, {illegal_pattern,Pat}, stacktrace()); + erlang:raise(error, {illegal_pattern,to_term(Pat)}, ?STACKTRACE); Other -> Other end. @@ -1254,7 +1276,7 @@ merge_bindings(Bs1, Bs2) -> case orddict:find(Name, Bs) of {ok,Val} -> Bs; %Already with SAME value {ok,V1} -> - erlang:raise(error, {badmatch,V1}, stacktrace()); + erlang:raise(error, {badmatch,V1}, ?STACKTRACE); error -> orddict:store(Name, Val, Bs) end end, Bs2, orddict:to_list(Bs1)). @@ -1264,10 +1286,234 @@ merge_bindings(Bs1, Bs2) -> %% fun (Name, Val, Bs) -> %% case orddict:find(Name, Bs) of %% {ok,Val} -> orddict:erase(Name, Bs); -%% {ok,V1} -> erlang:raise(error,{badmatch,V1},stacktrace()); +%% {ok,V1} -> erlang:raise(error,{badmatch,V1},?STACKTRACE); %% error -> Bs %% end %% end, Bs2, Bs1). + +to_terms(Abstrs) -> + [to_term(Abstr) || Abstr <- Abstrs]. + +to_term(Abstr) -> + erl_parse:anno_to_term(Abstr). + +%% Substitute {value, A, Item} for {var, A, Var}, preserving A. +%% {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 :: 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. + +%% `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) -> + []. + %%---------------------------------------------------------------------------- %% %% Evaluate expressions: @@ -1306,6 +1552,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}) -> @@ -1319,13 +1566,53 @@ ev_expr({cons,_,H,T}) -> [ev_expr(H) | ev_expr(T)]. %% true = erl_internal:guard_bif(F, length(As)), %% apply(erlang, F, [ev_expr(X) || X <- As]); +%% eval_str(InStr) -> {ok, OutStr} | {error, ErrStr'} +%% InStr must represent a body +%% Note: If InStr is a binary it has to be a Latin-1 string. +%% If you have a UTF-8 encoded binary you have to call +%% unicode:characters_to_list/1 before the call to eval_str(). + +-define(result(F,D), lists:flatten(io_lib:format(F, D))). + +-spec eval_str(string() | unicode:latin1_binary()) -> + {'ok', string()} | {'error', string()}. + +eval_str(Str) when is_list(Str) -> + case erl_scan:tokens([], Str, 0) of + {more, _} -> + {error, "Incomplete form (missing .<cr>)??"}; + {done, {ok, Toks, _}, Rest} -> + case all_white(Rest) of + true -> + case erl_parse:parse_exprs(Toks) of + {ok, Exprs} -> + case catch erl_eval:exprs(Exprs, erl_eval:new_bindings()) of + {value, Val, _} -> + {ok, Val}; + Other -> + {error, ?result("*** eval: ~p", [Other])} + end; + {error, {_Line, Mod, Args}} -> + Msg = ?result("*** ~ts",[Mod:format_error(Args)]), + {error, Msg} + end; + false -> + {error, ?result("Non-white space found after " + "end-of-form :~ts", [Rest])} + end + end; +eval_str(Bin) when is_binary(Bin) -> + eval_str(binary_to_list(Bin)). + +all_white([$\s|T]) -> all_white(T); +all_white([$\n|T]) -> all_white(T); +all_white([$\t|T]) -> all_white(T); +all_white([]) -> true; +all_white(_) -> false. + ret_expr(_Old, New) -> %% io:format("~w: reduced ~s => ~s~n", %% [line(Old), erl_pp:expr(Old), erl_pp:expr(New)]), New. line(Expr) -> element(2, Expr). - -%% {?MODULE,expr,3} is still the stacktrace, despite the -%% fact that expr() now takes two, three or four arguments... -stacktrace() -> [{?MODULE,expr,3}]. 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..939abaff00 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-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. @@ -54,6 +54,8 @@ -export([is_type/2]). +-export([add_predefined_functions/1]). + %%--------------------------------------------------------------------------- %% Erlang builtin functions allowed in guards. @@ -61,42 +63,30 @@ 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(is_map_key, 2) -> true; +guard_bif(length, 1) -> true; guard_bif(map_size, 1) -> true; +guard_bif(map_get, 2) -> 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 +99,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 +113,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 +262,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 +283,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; @@ -323,6 +316,7 @@ bif(is_function, 2) -> true; bif(is_integer, 1) -> true; bif(is_list, 1) -> true; bif(is_map, 1) -> true; +bif(is_map_key, 2) -> true; bif(is_number, 1) -> true; bif(is_pid, 1) -> true; bif(is_port, 1) -> true; @@ -340,10 +334,13 @@ 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; bif(map_size,1) -> true; +bif(map_get,2) -> true; bif(max,2) -> true; bif(min,2) -> true; bif(module_loaded, 1) -> true; @@ -357,6 +354,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 +368,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 +583,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 62b3169a6c..e9ac2fcdff 100644 --- a/lib/stdlib/src/erl_lint.erl +++ b/lib/stdlib/src/erl_lint.erl @@ -2,7 +2,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2016. 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. @@ -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,6 +92,7 @@ value_option(Flag, Default, On, OnVal, Off, OffVal, Opts) -> :: dict:dict(ta(), line()) }). + %% Define the lint state record. %% 'called' and 'exports' contain {Line, {Function, Arity}}, %% the other function collections contain {Function, Arity}. @@ -103,7 +100,7 @@ value_option(Flag, Default, On, OnVal, Off, OffVal, Opts) -> 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 +136,8 @@ 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()), + in_try_head=false :: boolean() %In a try head. }). -type lint_state() :: #lint{}. @@ -160,6 +158,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 +167,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 +224,6 @@ 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({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 +236,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 +255,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 +263,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]); @@ -290,9 +295,13 @@ format_error({unused_var, V}) -> io_lib:format("variable ~w is unused", [V]); format_error({variable_in_record_def,V}) -> io_lib:format("variable ~w in record definition", [V]); +format_error({stacktrace_guard,V}) -> + io_lib:format("stacktrace variable ~w must not be used in a guard", [V]); +format_error({stacktrace_bound,V}) -> + io_lib:format("stacktrace variable ~w must not be previously bound", [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]); @@ -312,13 +321,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]); @@ -329,23 +338,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", @@ -357,26 +366,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 @@ -391,11 +404,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). @@ -416,6 +433,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) -> @@ -462,7 +482,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()). @@ -474,7 +494,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]}], @@ -487,7 +507,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]}], @@ -517,7 +537,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)}, @@ -694,7 +714,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). @@ -719,11 +744,17 @@ 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) -> @@ -766,8 +797,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); @@ -808,9 +838,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 @@ -853,7 +884,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. @@ -917,7 +949,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) -> @@ -1136,7 +1169,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)], @@ -1146,7 +1179,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. @@ -1254,7 +1288,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 [] -> @@ -1370,8 +1405,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}}, + St2 = define_function(Line, Name, Arity, St1), + clauses(Cs, St2). -spec define_function(line(), atom(), arity(), lint_state()) -> lint_state(). @@ -1491,7 +1527,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) -> @@ -1506,56 +1542,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_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_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_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), @@ -1571,7 +1628,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]. @@ -1733,7 +1790,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}; @@ -1968,77 +2026,108 @@ 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({map,_L,Es}, Info) -> + is_map_fields(Es, Info); +is_gexpr({map,_L,Src,Es}, Info) -> + is_gexpr(Src, Info) andalso is_map_fields(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 @@ -2050,14 +2139,22 @@ 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_map_fields([{Tag,_,K,V}|Fs], Info) when Tag =:= map_field_assoc; + Tag =:= map_field_exact -> + is_gexpr(K, Info) andalso + is_gexpr(V, Info) andalso + is_map_fields(Fs, Info); +is_map_fields([], _Info) -> true; +is_map_fields(_T, _Info) -> false. -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) -> @@ -2188,11 +2285,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), @@ -2258,7 +2362,8 @@ expr({'try',Line,Es,Scs,Ccs,As}, Vt, St0) -> 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), @@ -2273,7 +2378,7 @@ expr({'catch',Line,E}, Vt, St0) -> 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) -> @@ -2370,7 +2475,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; @@ -2436,7 +2541,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}. @@ -2639,11 +2747,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), @@ -2705,10 +2810,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 @@ -2746,10 +2850,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) @@ -2806,6 +2908,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}; @@ -2855,7 +2959,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) -> @@ -2868,15 +2971,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. @@ -2884,13 +2988,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. @@ -2927,7 +3034,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]} -> @@ -2935,18 +3052,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() -> @@ -2988,9 +3103,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) @@ -3003,7 +3119,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 @@ -3037,6 +3155,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{in_try_head=true}, + {Csvt1,St3} = icrt_clauses(Ccs, Vt, St2), + Csvt = Csvt0 ++ Csvt1, + UpdVt = icrt_export(Csvt, Vt, In, St3), + {UpdVt,St3#lint{in_try_head=false}}. + %% icrt_clauses(Clauses, In, ImportVarTable, State) -> %% {UpdVt,State}. @@ -3052,12 +3234,29 @@ 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) -> - {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}. + Vt1 = taint_stack_var(Vt0, H, St0), + {Hvt,Binvt,St1} = head(H, Vt1, St0), + Vt2 = vtupdate(Hvt, Binvt), + Vt3 = taint_stack_var(Vt2, H, St0), + {Gvt,St2} = guard(G, vtupdate(Vt3, Vt0), St1#lint{in_try_head=false}), + Vt4 = vtupdate(Gvt, Vt2), + {Bvt,St3} = exprs(B, vtupdate(Vt4, Vt0), St2), + {vtupdate(Bvt, Vt4),St3}. + +taint_stack_var(Vt, Pat, #lint{in_try_head=true}) -> + [{tuple,_,[_,_,{var,_,Stk}]}] = Pat, + case Stk of + '_' -> + Vt; + _ -> + lists:map(fun({V,{bound,Used,Lines}}) when V =:= Stk -> + {V,{stacktrace,Used,Lines}}; + (B) -> + B + end, Vt) + end; +taint_stack_var(Vt, _Pat, #lint{in_try_head=false}) -> + Vt. icrt_export(Vts, Vt, {Tag,Attrs}, St) -> {_File,Loc} = loc(Attrs, St), @@ -3162,7 +3361,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, @@ -3170,6 +3370,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. @@ -3190,8 +3396,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 -> @@ -3290,6 +3496,9 @@ pat_var(V, Line, Vt, Bvt, St) -> {[{V,{bound,used,Ls}}],[], %% As this is matching, exported vars are risky. add_warning(Line, {exported_var,V,From}, St)}; + {ok,{stacktrace,_Usage,Ls}} -> + {[{V,{bound,used,Ls}}],[], + add_error(Line, {stacktrace_bound,V}, St)}; error when St#lint.recdef_top -> {[],[{V,{bound,unused,[Line]}}], add_error(Line, {variable_in_record_def,V}, St)}; @@ -3347,6 +3556,9 @@ expr_var(V, Line, Vt, St) -> false -> {[{V,{{export,From},used,Ls}}],St} end; + {ok,{stacktrace,_Usage,Ls}} -> + {[{V,{bound,used,Ls}}], + add_error(Line, {stacktrace_guard,V}, St)}; error -> {[{V,{bound,used,[Line]}}], add_error(Line, {unbound_var,V}, St)} @@ -3403,6 +3615,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 @@ -3485,13 +3705,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. @@ -3574,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. @@ -3584,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.) @@ -3685,10 +3910,9 @@ check_format_string(Fmt) -> extract_sequences(Fmt, []). extract_sequences(Fmt, Need0) -> - case string:chr(Fmt, $~) of - 0 -> {ok,lists:reverse(Need0)}; %That's it - Pos -> - Fmt1 = string:substr(Fmt, Pos+1), %Skip ~ + case string:find(Fmt, [$~]) of + nomatch -> {ok,lists:reverse(Need0)}; %That's it + [$~|Fmt1] -> case extract_sequence(1, Fmt1, Need0) of {ok,Need1,Rest} -> extract_sequences(Rest, Need1); Error -> Error @@ -3719,6 +3943,8 @@ extract_sequence(3, [$.,_|Fmt], Need) -> extract_sequence(4, Fmt, Need); extract_sequence(3, Fmt, Need) -> extract_sequence(4, Fmt, Need); +extract_sequence(4, [$t, $l | Fmt], Need) -> + extract_sequence(4, [$l, $t | Fmt], Need); extract_sequence(4, [$t, $c | Fmt], Need) -> extract_sequence(5, [$c|Fmt], Need); extract_sequence(4, [$t, $s | Fmt], Need) -> @@ -3727,12 +3953,22 @@ 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) -> extract_sequence(5, [$p|Fmt], Need); +extract_sequence(4, [$l, $t, $p | Fmt], Need) -> + extract_sequence(5, [$p|Fmt], Need); extract_sequence(4, [$l, $P | Fmt], Need) -> extract_sequence(5, [$P|Fmt], Need); +extract_sequence(4, [$l, $t, $P | Fmt], Need) -> + extract_sequence(5, [$P|Fmt], Need); +extract_sequence(4, [$l, $t, C | _Fmt], _Need) -> + {error,"invalid control ~lt" ++ [C]}; extract_sequence(4, [$l, C | _Fmt], _Need) -> {error,"invalid control ~l" ++ [C]}; extract_sequence(4, Fmt, Need) -> diff --git a/lib/stdlib/src/erl_parse.yrl b/lib/stdlib/src/erl_parse.yrl index e82282421e..9602f0bcd9 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-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. @@ -29,16 +29,19 @@ clause_args clause_guard clause_body expr expr_100 expr_150 expr_160 expr_200 expr_300 expr_400 expr_500 expr_600 expr_700 expr_800 expr_max +pat_expr pat_expr_200 pat_expr_300 pat_expr_400 pat_expr_500 +pat_expr_600 pat_expr_700 pat_expr_800 +pat_expr_max map_pat_expr record_pat_expr +pat_argument_list pat_exprs 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 fun_expr fun_clause fun_clauses atom_or_var integer_or_var -try_expr try_catch try_clause try_clauses +try_expr try_catch try_clause try_clauses try_opt_stacktrace function_call argument_list exprs guard atomic strings @@ -67,7 +70,7 @@ char integer float atom string var 'spec' 'callback' % helper dot. -Expect 2. +Expect 0. Rootsymbol form. @@ -85,10 +88,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 +111,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 +158,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 +175,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']. @@ -211,7 +214,7 @@ function_clause -> atom clause_args clause_guard clause_body : {clause,?anno('$1'),element(3, '$1'),'$2','$3','$4'}. -clause_args -> argument_list : element(1, '$1'). +clause_args -> pat_argument_list : element(1, '$1'). clause_guard -> 'when' guard : '$2'. clause_guard -> '$empty' : []. @@ -268,7 +271,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'. @@ -277,6 +279,53 @@ expr_max -> receive_expr : '$1'. expr_max -> fun_expr : '$1'. expr_max -> try_expr : '$1'. +pat_expr -> pat_expr_200 '=' pat_expr : {match,?anno('$2'),'$1','$3'}. +pat_expr -> pat_expr_200 : '$1'. + +pat_expr_200 -> pat_expr_300 comp_op pat_expr_300 : + ?mkop2('$1', '$2', '$3'). +pat_expr_200 -> pat_expr_300 : '$1'. + +pat_expr_300 -> pat_expr_400 list_op pat_expr_300 : + ?mkop2('$1', '$2', '$3'). +pat_expr_300 -> pat_expr_400 : '$1'. + +pat_expr_400 -> pat_expr_400 add_op pat_expr_500 : + ?mkop2('$1', '$2', '$3'). +pat_expr_400 -> pat_expr_500 : '$1'. + +pat_expr_500 -> pat_expr_500 mult_op pat_expr_600 : + ?mkop2('$1', '$2', '$3'). +pat_expr_500 -> pat_expr_600 : '$1'. + +pat_expr_600 -> prefix_op pat_expr_700 : + ?mkop1('$1', '$2'). +pat_expr_600 -> map_pat_expr : '$1'. +pat_expr_600 -> pat_expr_700 : '$1'. + +pat_expr_700 -> record_pat_expr : '$1'. +pat_expr_700 -> pat_expr_800 : '$1'. + +pat_expr_800 -> pat_expr_max : '$1'. + +pat_expr_max -> var : '$1'. +pat_expr_max -> atomic : '$1'. +pat_expr_max -> list : '$1'. +pat_expr_max -> binary : '$1'. +pat_expr_max -> tuple : '$1'. +pat_expr_max -> '(' pat_expr ')' : '$2'. + +map_pat_expr -> '#' map_tuple : + {map, ?anno('$1'),'$2'}. +map_pat_expr -> pat_expr_max '#' map_tuple : + {map, ?anno('$2'),'$1','$3'}. +map_pat_expr -> map_pat_expr '#' map_tuple : + {map, ?anno('$2'),'$1','$3'}. + +record_pat_expr -> '#' atom '.' atom : + {record_index,?anno('$1'),element(3, '$2'),'$4'}. +record_pat_expr -> '#' atom record_tuple : + {record,?anno('$1'),element(3, '$2'),'$3'}. list -> '[' ']' : {nil,?anno('$1')}. list -> '[' expr tail : {cons,?anno('$1'),'$2','$3'}. @@ -315,7 +364,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 +376,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 : @@ -403,6 +448,10 @@ case_expr -> 'case' expr 'of' cr_clauses 'end' : cr_clauses -> cr_clause : ['$1']. cr_clauses -> cr_clause ';' cr_clauses : ['$1' | '$3']. +%% FIXME: merl in syntax_tools depends on patterns in a 'case' being +%% full expressions. Therefore, we can't use pat_expr here. There +%% should be a better way. + cr_clause -> expr clause_guard clause_body : {clause,?anno('$1'),['$1'],'$2','$3'}. @@ -430,11 +479,11 @@ integer_or_var -> var : '$1'. fun_clauses -> fun_clause : ['$1']. fun_clauses -> fun_clause ';' fun_clauses : ['$1' | '$3']. -fun_clause -> argument_list clause_guard clause_body : +fun_clause -> pat_argument_list clause_guard clause_body : {Args,Anno} = '$1', {clause,Anno,'fun',Args,'$2','$3'}. -fun_clause -> var argument_list clause_guard clause_body : +fun_clause -> var pat_argument_list clause_guard clause_body : {clause,element(2, '$1'),element(3, '$1'),element(1, '$2'),'$3','$4'}. try_expr -> 'try' exprs 'of' cr_clauses try_catch : @@ -452,24 +501,31 @@ try_catch -> 'after' exprs 'end' : try_clauses -> try_clause : ['$1']. try_clauses -> try_clause ';' try_clauses : ['$1' | '$3']. -try_clause -> expr clause_guard clause_body : +try_clause -> pat_expr clause_guard clause_body : A = ?anno('$1'), {clause,A,[{tuple,A,[{atom,A,throw},'$1',{var,A,'_'}]}],'$2','$3'}. -try_clause -> atom ':' expr clause_guard clause_body : +try_clause -> atom ':' pat_expr try_opt_stacktrace clause_guard clause_body : A = ?anno('$1'), - {clause,A,[{tuple,A,['$1','$3',{var,A,'_'}]}],'$4','$5'}. -try_clause -> var ':' expr clause_guard clause_body : + {clause,A,[{tuple,A,['$1','$3',{var,A,'$4'}]}],'$5','$6'}. +try_clause -> var ':' pat_expr try_opt_stacktrace clause_guard clause_body : A = ?anno('$1'), - {clause,A,[{tuple,A,['$1','$3',{var,A,'_'}]}],'$4','$5'}. + {clause,A,[{tuple,A,['$1','$3',{var,A,'$4'}]}],'$5','$6'}. +try_opt_stacktrace -> ':' var : element(3, '$2'). +try_opt_stacktrace -> '$empty' : '_'. argument_list -> '(' ')' : {[],?anno('$1')}. argument_list -> '(' exprs ')' : {'$2',?anno('$1')}. +pat_argument_list -> '(' ')' : {[],?anno('$1')}. +pat_argument_list -> '(' pat_exprs ')' : {'$2',?anno('$1')}. exprs -> expr : ['$1']. exprs -> expr ',' exprs : ['$1' | '$3']. +pat_exprs -> pat_expr : ['$1']. +pat_exprs -> pat_expr ',' pat_exprs : ['$1' | '$3']. + guard -> exprs : ['$1']. guard -> exprs ';' guard : ['$1'|'$3']. @@ -516,6 +572,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 +597,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 +1043,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 +1062,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 +1078,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 +1091,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 +1114,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 +1132,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 +1152,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 +1282,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 +1301,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") @@ -891,6 +1377,8 @@ normalise({map,_,Pairs}=M) -> ({map_field_assoc,_,K,V}) -> {normalise(K),normalise(V)}; (_) -> erlang:error({badarg,M}) end, Pairs)); +normalise({'fun',_,{function,{atom,_,M},{atom,_,F},{integer,_,A}}}) -> + fun M:F/A; %% Special case for unary +/-. normalise({op,_,'+',{char,_,I}}) -> I; normalise({op,_,'+',{integer,_,I}}) -> I; @@ -1118,47 +1606,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 +1638,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 +1713,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..8959fea498 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-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. @@ -64,6 +64,7 @@ message_1(eduppkg) -> <<"duplicate package name">>; message_1(eexist) -> <<"file already exists">>; message_1(efault) -> <<"bad address in system call argument">>; message_1(efbig) -> <<"file too large">>; +message_1(eftype) -> <<"EFTYPE">>; message_1(ehostdown) -> <<"host is down">>; message_1(ehostunreach) -> <<"host is unreachable">>; message_1(eidrm) -> <<"identifier removed">>; @@ -115,6 +116,7 @@ message_1(enopkg) -> <<"package not installed">>; message_1(enoprotoopt) -> <<"bad proocol option">>; message_1(enospc) -> <<"no space left on device">>; message_1(enosr) -> <<"out of stream resources or not a stream device">>; +message_1(enostr) -> <<"not a stream">>; message_1(enosym) -> <<"unresolved symbol name">>; message_1(enosys) -> <<"function not implemented">>; message_1(enotblk) -> <<"block device required">>; @@ -128,6 +130,7 @@ message_1(enotty) -> <<"inappropriate device for ioctl">>; message_1(enotuniq) -> <<"name not unique on network">>; message_1(enxio) -> <<"no such device or address">>; message_1(eopnotsupp) -> <<"operation not supported on socket">>; +message_1(eoverflow) -> <<"offset too large for file system">>; message_1(eperm) -> <<"not owner">>; message_1(epfnosupport) -> <<"protocol family not supported">>; message_1(epipe) -> <<"broken pipe">>; @@ -167,4 +170,6 @@ message_1(ewouldblock) -> <<"operation would block">>; message_1(exdev) -> <<"cross-domain link">>; message_1(exfull) -> <<"message tables full">>; message_1(nxdomain) -> <<"non-existing domain">>; +message_1(exbadport) -> <<"inet_drv bad port state">>; +message_1(exbadseq) -> <<"inet_drv bad request sequence">>; message_1(_) -> <<"unknown POSIX error">>. diff --git a/lib/stdlib/src/erl_pp.erl b/lib/stdlib/src/erl_pp.erl index c5177aca90..dd302a2880 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-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. @@ -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,56 +232,62 @@ 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) -> - leaf(format("~p\n", [{error,E}])); -lform({warning,W}, _Opts, _State) -> - leaf(format("~p\n", [{warning,W}])); -lform({eof,_Line}, _Opts, _State) -> +lform({error,_}=E, Opts) -> + message(E, Opts); +lform({warning,_}=W, Opts) -> + message(W, Opts); +lform({eof,_Line}, _Opts) -> $\n. -lattribute({attribute,_Line,type,Type}, Opts, _State) -> +message(M, #options{encoding = Encoding}) -> + F = case Encoding of + latin1 -> "~p\n"; + unicode -> "~tp\n" + end, + leaf(format(F, [M])). + +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(export_type, Talist, _Opts, _State) -> - call({var,a0(),"-export_type"}, [falist(Talist)], 0, options(none)); -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}]). @@ -329,7 +350,7 @@ ltype({user_type,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)). @@ -348,7 +369,9 @@ map_pair_types(Fs) -> tuple_type(Fs, fun map_pair_type/2). map_pair_type({type,_Line,map_field_assoc,[KType,VType]}, Prec) -> - {list,[{cstep,[ltype(KType, Prec),leaf(" =>")],ltype(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)}. @@ -369,12 +392,12 @@ tuple_type(Ts, F) -> 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]}. @@ -416,7 +439,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)]; @@ -428,10 +454,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), @@ -476,7 +505,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) -> @@ -506,7 +535,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) -> @@ -525,12 +554,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']}; @@ -550,13 +579,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), @@ -573,8 +605,6 @@ lexpr({'fun',_,{clauses,Cs},Extra}, _Prec, Opts) -> lexpr({named_fun,_,Name,Cs,Extra}, _Prec, Opts) -> {force_nl,fun_info(Extra), {list,[{first,['fun', " "],fun_clauses(Cs, Opts, {named, Name})},'end']}}; -lexpr({'query',_,Lc}, _Prec, Opts) -> - {list,[{step,leaf("query"),lexpr(Lc, 0, Opts)},'end']}; lexpr({call,_,{remote,_,{atom,_,M},{atom,_,F}=N}=Name,Args}, Prec, Opts) -> case erl_internal:bif(M, F, length(Args)) of true -> @@ -647,7 +677,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])); @@ -663,7 +693,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: @@ -704,7 +734,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). @@ -879,7 +909,7 @@ maybe_paren(_P, _Prec, Expr) -> Expr. leaf(S) -> - {leaf,chars_size(S),S}. + {leaf,string:length(S),S}. %%% Do the formatting. Currently nothing fancy. Could probably have %%% done it in one single pass. @@ -906,8 +936,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 @@ -937,7 +969,7 @@ f({seq,Before,After,Sep,LItems}, I0, ST, WT, PP) -> Sizes = BSizeL ++ SizeL, NSepChars = if is_list(Sep), Sep =/= [] -> - erlang:max(0, length(CharsL)-1); + erlang:max(0, length(CharsL)-1); % not string:length true -> 0 end, @@ -968,6 +1000,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) -> @@ -1089,7 +1125,7 @@ incr(I, Incr) -> I+Incr. indentation(E, I) when I < 0 -> - chars_size(E); + string:length(E); indentation(E, I0) -> I = io_lib_format:indentation(E, I0), case has_nl(E) of @@ -1106,6 +1142,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)). @@ -1120,25 +1162,31 @@ write_a_string(S, I, PP) -> write_a_string([], _N, _Len, _PP) -> []; write_a_string(S, N, Len, PP) -> - SS = string:sub_string(S, 1, N), + SS = string:slice(S, 0, N), Sl = write_string(SS, PP), - case (length(Sl) > Len) and (N > ?MIN_SUBSTRING) of + case (string:length(Sl) > Len) and (N > ?MIN_SUBSTRING) of true -> write_a_string(S, N-1, Len, PP); false -> [flat_leaf(Sl) | - write_a_string(lists:nthtail(length(SS), S), Len, Len, PP)] + write_a_string(string:slice(S, string:length(SS)), Len, Len, PP)] end. flat_leaf(S) -> L = lists:flatten(S), - {leaf,length(L),L}. + {leaf,string: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 @@ -1147,15 +1195,6 @@ write_char(C, PP) -> a0() -> erl_anno:new(0). -chars_size([C | Es]) when is_integer(C) -> - 1 + chars_size(Es); -chars_size([E | Es]) -> - chars_size(E) + chars_size(Es); -chars_size([]) -> - 0; -chars_size(B) when is_binary(B) -> - byte_size(B). - -define(N_SPACES, 30). spacetab() -> diff --git a/lib/stdlib/src/erl_scan.erl b/lib/stdlib/src/erl_scan.erl index d2f53816b8..4774c4bf19 100644 --- a/lib/stdlib/src/erl_scan.erl +++ b/lib/stdlib/src/erl_scan.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. @@ -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}} -> @@ -975,7 +752,7 @@ scan_string(Cs, St, Line, Col, Toks, {Wcs,Str,Line0,Col0}) -> {char_error,Ncs,Error,Nline,Ncol,EndCol} -> scan_error(Error, Nline, Ncol, Nline, EndCol, Ncs); {error,Nline,Ncol,Nwcs,Ncs} -> - Estr = string:substr(Nwcs, 1, 16), % Expanded escape chars. + Estr = string:slice(Nwcs, 0, 16), % Expanded escape chars. scan_error({string,$\",Estr}, Line0, Col0, Nline, Ncol, Ncs); %" {Ncs,Nline,Ncol,Nstr,Nwcs} -> Anno = anno(Line0, Col0, St, Nstr), @@ -990,7 +767,7 @@ scan_qatom(Cs, St, Line, Col, Toks, {Wcs,Str,Line0,Col0}) -> {char_error,Ncs,Error,Nline,Ncol,EndCol} -> scan_error(Error, Nline, Ncol, Nline, EndCol, Ncs); {error,Nline,Ncol,Nwcs,Ncs} -> - Estr = string:substr(Nwcs, 1, 16), % Expanded escape chars. + Estr = string:slice(Nwcs, 0, 16), % Expanded escape chars. scan_error({string,$\',Estr}, Line0, Col0, Nline, Ncol, Ncs); %' {Ncs,Nline,Ncol,Nstr,Nwcs} -> case catch list_to_atom(Nwcs) of diff --git a/lib/stdlib/src/erl_tar.erl b/lib/stdlib/src/erl_tar.erl index d0e7a827a8..d8b8f466b1 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-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 @@ -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,1651 @@ 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}. + +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]). -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%% -%%% 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}} +%%%================================================================ +%% 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; -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 +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. -add_directory(TarFile, DirName, NameInArchive, Info, Options) -> +%% 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 = apply_file_info_opts_fun(Options, read_link_info), + Opts = #add_opts{read_info=RF}, + add1(Reader, Name, NameInArchive, add_opts(Options, Options, Opts)); +do_add(#reader{access=read},_,_,_) -> + {error, eacces}; +do_add(Reader,_,_,_) -> + {error, {badarg, Reader}}. + +add_opts([dereference|T], AllOptions, Opts) -> + RF = apply_file_info_opts_fun(AllOptions, read_file_info), + add_opts(T, AllOptions, Opts#add_opts{read_info=RF}); +add_opts([verbose|T], AllOptions, Opts) -> + add_opts(T, AllOptions, Opts#add_opts{verbose=true}); +add_opts([{chunks,N}|T], AllOptions, Opts) -> + add_opts(T, AllOptions, Opts#add_opts{chunk_size=N}); +add_opts([{atime,Value}|T], AllOptions, Opts) -> + add_opts(T, AllOptions, Opts#add_opts{atime=Value}); +add_opts([{mtime,Value}|T], AllOptions, Opts) -> + add_opts(T, AllOptions, Opts#add_opts{mtime=Value}); +add_opts([{ctime,Value}|T], AllOptions, Opts) -> + add_opts(T, AllOptions, Opts#add_opts{ctime=Value}); +add_opts([{uid,Value}|T], AllOptions, Opts) -> + add_opts(T, AllOptions, Opts#add_opts{uid=Value}); +add_opts([{gid,Value}|T], AllOptions, Opts) -> + add_opts(T, AllOptions, Opts#add_opts{gid=Value}); +add_opts([_|T], AllOptions, Opts) -> + add_opts(T, AllOptions, Opts); +add_opts([], _AllOptions, Opts) -> + Opts. + +apply_file_info_opts(Opts, {ok, FileInfo}) -> + {ok, do_apply_file_info_opts(Opts, FileInfo)}; +apply_file_info_opts(_Opts, Other) -> + Other. + +do_apply_file_info_opts([{atime,Value}|T], FileInfo) -> + do_apply_file_info_opts(T, FileInfo#file_info{atime=Value}); +do_apply_file_info_opts([{mtime,Value}|T], FileInfo) -> + do_apply_file_info_opts(T, FileInfo#file_info{mtime=Value}); +do_apply_file_info_opts([{ctime,Value}|T], FileInfo) -> + do_apply_file_info_opts(T, FileInfo#file_info{ctime=Value}); +do_apply_file_info_opts([{uid,Value}|T], FileInfo) -> + do_apply_file_info_opts(T, FileInfo#file_info{uid=Value}); +do_apply_file_info_opts([{gid,Value}|T], FileInfo) -> + do_apply_file_info_opts(T, FileInfo#file_info{gid=Value}); +do_apply_file_info_opts([_|T], FileInfo) -> + do_apply_file_info_opts(T, FileInfo); +do_apply_file_info_opts([], FileInfo) -> + FileInfo. + +apply_file_info_opts_fun(Options, InfoFunction) -> + fun(F) -> + apply_file_info_opts(Options, file:InfoFunction(F, [{time, posix}])) + end. + +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(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 = add_opts_time(Opts#add_opts.atime, Now), + mtime = add_opts_time(Opts#add_opts.mtime, Now), + ctime = add_opts_time(Opts#add_opts.ctime, Now), + uid = Opts#add_opts.uid, + gid = Opts#add_opts.gid, + 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_opts_time(undefined, Now) -> Now; +add_opts_time(Time, _Now) -> Time. + +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. + +get_header(#reader{}=Reader) -> + case read_block(Reader) of + eof -> + eof; + {ok, Block, Reader1} -> + convert_header(Block, Reader1) 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 +%% 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. -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) +-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. -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} +-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. -%% Checks if the file Name should be extracted. +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. -check_extract(_, #read_opts{files=all}) -> +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; +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) when byte_size(Bin) =:= 0 -> +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} -> + case make_dirs(Name, file) of + ok -> + write_file(Name, Bin); + {error,Reason} -> + throw({error, Reason}) + end; + {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. - -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. +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. -%% Skips to the next record in the file. -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_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. -%% Prints the message on if the verbose option is given. +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. -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..5d6cecbb66 --- /dev/null +++ b/lib/stdlib/src/erl_tar.hrl @@ -0,0 +1,406 @@ +%% +%% %CopyrightBegin% +%% +%% 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. +%% 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. + atime = undefined, + mtime = undefined, + ctime = undefined, + uid = 0, + gid = 0}). +-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()} | + {atime, non_neg_integer()} | + {mtime, non_neg_integer()} | + {ctime, non_neg_integer()} | + {uid, non_neg_integer()} | + {gid, non_neg_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 fea1656051..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. @@ -55,9 +55,9 @@ 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} -> - Depth = get_depth(), + Depth = error_logger:get_format_depth(), State = #st{fd=Fd,filename=File,prev_handler=PrevHandler, depth=Depth}, {ok, State}; @@ -65,14 +65,6 @@ init(File, PrevHandler) -> Error end. -get_depth() -> - case application:get_env(kernel, error_logger_format_depth) of - {ok, Depth} when is_integer(Depth) -> - max(10, Depth); - undefined -> - unlimited - end. - handle_event({_Type, GL, _Msg}, State) when node(GL) =/= node() -> {ok, State}; handle_event(Event, State) -> @@ -116,8 +108,8 @@ write_event(#st{fd=Fd}=State, Event) -> ignore -> ok; {Head,Pid,FormatList} -> - Time = maybe_utc(erlang:universaltime()), - Header = write_time(Time, Head), + Time = erlang:universaltime(), + Header = header(Time, Head), Body = format_body(State, FormatList), AtNode = if node(Pid) =/= node() -> @@ -125,7 +117,7 @@ write_event(#st{fd=Fd}=State, Event) -> true -> [] end, - io:put_chars(Fd, [Header,Body,AtNode]) + io:put_chars(Fd, [Header,AtNode,Body]) end. format_body(State, [{Format,Args}|T]) -> @@ -134,7 +126,7 @@ format_body(State, [{Format,Args}|T]) -> S0 catch _:_ -> - format(State, "ERROR: ~p - ~p\n", [Format,Args]) + format(State, "ERROR: ~tp - ~tp\n", [Format,Args]) end, [S|format_body(State, T)]; format_body(_State, []) -> @@ -172,72 +164,55 @@ parse_event({warning_report, _GL, {Pid, std_warning, Args}}) -> {"WARNING REPORT",Pid,format_term(Args)}; parse_event(_) -> ignore. -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_term(Term) when is_list(Term) -> - case string_p(Term) of + case string_p(lists:flatten(Term)) of true -> - [{"~s\n",[Term]}]; + [{"~ts\n",[Term]}]; false -> format_term_list(Term) end; format_term(Term) -> - [{"~p\n",[Term]}]. + [{"~tp\n",[Term]}]. format_term_list([{Tag,Data}|T]) -> - [{" ~p: ~p\n",[Tag,Data]}|format_term_list(T)]; + [{" ~tp: ~tp\n",[Tag,Data]}|format_term_list(T)]; format_term_list([Data|T]) -> - [{" ~p\n",[Data]}|format_term_list(T)]; + [{" ~tp\n",[Data]}|format_term_list(T)]; format_term_list([]) -> - []; -format_term_list(_) -> - %% Continue to allow non-proper lists for now. - %% FIXME: Remove this clause in OTP 19. []. string_p([]) -> false; -string_p(Term) -> - string_p1(Term). +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. -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) -> - string_p1(H) andalso string_p1(T); -string_p1([]) -> true; -string_p1(_) -> false. +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. @@ -253,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 d2df6681e3..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. @@ -39,13 +39,16 @@ {user, prev_handler, io_mod=io, - depth=unlimited}). + depth=unlimited, + modifier=""}). %% This one is used when we takeover from the simple error_logger. init({[], {error_logger, Buf}}) -> User = set_group_leader(), - Depth = get_depth(), - State = #st{user=User,prev_handler=error_logger,depth=Depth}, + 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 @@ -56,17 +59,10 @@ init({[], {error_logger_tty_h, PrevHandler}}) -> %% This one is used when we are started directly. init([]) -> User = set_group_leader(), - Depth = get_depth(), - {ok, #st{user=User,prev_handler=[],depth=Depth}}. - -get_depth() -> - case application:get_env(kernel, error_logger_format_depth) of - {ok, Depth} when is_integer(Depth) -> - max(10, Depth); - undefined -> - unlimited - end. - + 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) -> @@ -99,8 +95,9 @@ code_change(_OldVsn, State, _Extra) -> write_event(Event, IoMod) -> do_write_event(#st{io_mod=IoMod}, Event). -write_event(Event, IoMod, Depth) -> - do_write_event(#st{io_mod=IoMod,depth=Depth}, Event). +write_event(Event, IoMod, {Depth, Enc}) -> + Modifier = modifier(Enc), + do_write_event(#st{io_mod=IoMod,depth=Depth,modifier=Modifier}, Event). %%% ------------------------------------------------------ @@ -128,13 +125,12 @@ write_events(State, [Ev|Es]) -> write_events(_State, []) -> ok. -do_write_event(State, {Time0, Event}) -> - case parse_event(Event) of +do_write_event(#st{modifier=M}=State, {Time, Event}) -> + case parse_event(Event,M) of ignore -> ok; - {Head,Pid,FormatList} -> - Time = maybe_utc(Time0), - Header = write_time(Time, Head), + {Title,Pid,FormatList} -> + Header = header(Time, Title, M), Body = format_body(State, FormatList), AtNode = if node(Pid) =/= node() -> @@ -142,7 +138,7 @@ do_write_event(State, {Time0, Event}) -> true -> [] end, - Str = [Header,Body,AtNode], + Str = [Header,AtNode,Body], case State#st.io_mod of io_lib -> Str; @@ -153,13 +149,13 @@ do_write_event(State, {Time0, Event}) -> do_write_event(_, _) -> ok. -format_body(State, [{Format,Args}|T]) -> +format_body(#st{modifier=M}=State, [{Format,Args}|T]) -> S = try format(State, Format, Args) of S0 -> S0 catch _:_ -> - format(State, "ERROR: ~p - ~p\n", [Format,Args]) + format(State, "ERROR: ~"++M++"p - ~"++M++"p\n", [Format,Args]) end, [S|format_body(State, T)]; format_body(_State, []) -> @@ -183,84 +179,65 @@ limit_format([H|T], Depth) -> limit_format([], _) -> []. -parse_event({error, _GL, {Pid, Format, Args}}) -> +parse_event({error, _GL, {Pid, Format, Args}},_) -> {"ERROR REPORT",Pid,[{Format,Args}]}; -parse_event({info_msg, _GL, {Pid, Format, Args}}) -> +parse_event({info_msg, _GL, {Pid, Format, Args}},_) -> {"INFO REPORT",Pid,[{Format, Args}]}; -parse_event({warning_msg, _GL, {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. - -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_term(Term) when is_list(Term) -> - case string_p(Term) of +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 -> - [{"~s\n",[Term]}]; + [{"~"++M++"s\n",[Term]}]; false -> - format_term_list(Term) + format_term_list(Term,M) end; -format_term(Term) -> - [{"~p\n",[Term]}]. - -format_term_list([{Tag,Data}|T]) -> - [{" ~p: ~p\n",[Tag,Data]}|format_term_list(T)]; -format_term_list([Data|T]) -> - [{" ~p\n",[Data]}|format_term_list(T)]; -format_term_list([]) -> - []; -format_term_list(_) -> - %% Continue to allow non-proper lists for now. - %% FIXME: Remove this clause in OTP 19. +format_term(Term,M) -> + [{"~"++M++"p\n",[Term]}]. + +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. -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(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. + +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)); @@ -282,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..3f14894b55 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-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 @@ -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}). @@ -224,8 +224,8 @@ return_sections(S, Bin) -> normalize_section(Name, undefined) -> {Name, undefined}; normalize_section(shebang, "#!" ++ Chars) -> - Chopped = string:strip(Chars, right, $\n), - Stripped = string:strip(Chopped, both), + Chopped = string:trim(Chars, trailing, "$\n"), + Stripped = string:trim(Chopped, both), if Stripped =:= ?SHEBANG -> {shebang, default}; @@ -233,8 +233,8 @@ normalize_section(shebang, "#!" ++ Chars) -> {shebang, Stripped} end; normalize_section(comment, Chars) -> - Chopped = string:strip(Chars, right, $\n), - Stripped = string:strip(string:strip(Chopped, left, $%), both), + Chopped = string:trim(Chars, trailing, "$\n"), + Stripped = string:trim(string:trim(Chopped, leading, "$%"), both), if Stripped =:= ?COMMENT -> {comment, default}; @@ -242,8 +242,8 @@ normalize_section(comment, Chars) -> {comment, Stripped} end; normalize_section(emu_args, "%%!" ++ Chars) -> - Chopped = string:strip(Chars, right, $\n), - Stripped = string:strip(Chopped, both), + Chopped = string:trim(Chars, trailing, "$\n"), + Stripped = string:trim(Chopped, both), {emu_args, Stripped}; normalize_section(Name, Chars) -> {Name, Chars}. @@ -281,11 +281,11 @@ 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()]), + _:Reason:Stk -> + io:format("escript: Internal error: ~tp\n", [Reason]), + io:format("~tp\n", [Stk]), my_halt(127) end. @@ -481,46 +481,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 +629,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 +727,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. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -757,8 +758,8 @@ run(Module, Args) -> Module:main(Args), my_halt(0) catch - Class:Reason -> - fatal(format_exception(Class, Reason)) + Class:Reason:StackTrace -> + fatal(format_exception(Class, Reason, StackTrace)) end. -spec interpret(_, _, _, _) -> no_return(). @@ -791,8 +792,8 @@ interpret(Forms, HasRecs, File, Args) -> end}), my_halt(0) catch - Class:Reason -> - fatal(format_exception(Class, Reason)) + Class:Reason:StackTrace -> + fatal(format_exception(Class, Reason, StackTrace)) end. report_errors(Errors) -> @@ -858,7 +859,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. @@ -871,7 +872,7 @@ eval_exprs([E|Es], Bs0, Lf, Ef, RBs) -> {value,_V,Bs} = erl_eval:expr(E, Bs0, Lf, Ef, RBs1), eval_exprs(Es, Bs, Lf, Ef, RBs). -format_exception(Class, Reason) -> +format_exception(Class, Reason, StackTrace) -> Enc = encoding(), P = case Enc of latin1 -> "P"; @@ -880,9 +881,8 @@ format_exception(Class, Reason) -> PF = fun(Term, I) -> io_lib:format("~." ++ integer_to_list(I) ++ P, [Term, 50]) end, - StackTrace = erlang:get_stacktrace(), StackFun = fun(M, _F, _A) -> (M =:= erl_eval) or (M =:= ?MODULE) end, - lib:format_exception(1, Class, Reason, StackTrace, StackFun, PF, Enc). + erl_error:format_exception(1, Class, Reason, StackTrace, StackFun, PF, Enc). encoding() -> [{encoding, Encoding}] = enc(), @@ -906,6 +906,7 @@ anno(L) -> fatal(Str) -> throw(Str). +-spec my_halt(_) -> no_return(). my_halt(Reason) -> erlang:halt(Reason). @@ -913,8 +914,8 @@ hidden_apply(App, M, F, Args) -> try apply(fun() -> M end(), F, Args) catch - error:undef -> - case erlang:get_stacktrace() of + error:undef:StackTrace -> + case StackTrace of [{M,F,Args,_} | _] -> Arity = length(Args), Text = io_lib:format("Call to ~w:~w/~w in application ~w failed.\n", diff --git a/lib/stdlib/src/ets.erl b/lib/stdlib/src/ets.erl index 1fca3624dc..29f907ad73 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-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. @@ -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,36 @@ 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]). + update_counter/3, update_counter/4, update_element/3, + whereis/1]). + +%% internal exports +-export([internal_request_all/0, + internal_delete_all/2, + internal_select_delete/2]). -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 @@ -97,7 +118,15 @@ delete(_, _) -> -spec delete_all_objects(Tab) -> true when Tab :: tab(). -delete_all_objects(_) -> +delete_all_objects(Tab) -> + _ = ets:internal_delete_all(Tab, undefined), + true. + +-spec internal_delete_all(Tab, undefined) -> NumDeleted when + Tab :: tab(), + NumDeleted :: non_neg_integer(). + +internal_delete_all(_, _) -> erlang:nif_error(undef). -spec delete_object(Tab, Object) -> true when @@ -127,6 +156,7 @@ give_away(_, _, _) -> InfoList :: [InfoTuple], InfoTuple :: {compressed, boolean()} | {heir, pid() | none} + | {id, tid()} | {keypos, pos_integer()} | {memory, non_neg_integer()} | {name, atom()} @@ -144,7 +174,7 @@ info(_) -> -spec info(Tab, Item) -> Value | undefined when Tab :: tab(), - Item :: compressed | fixed | heir | keypos | memory + Item :: compressed | fixed | heir | id | keypos | memory | name | named_table | node | owner | protection | safe_fixed | safe_fixed_monotonic_time | size | stats | type | write_concurrency | read_concurrency, @@ -232,20 +262,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 +289,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(_, _, _) -> @@ -358,7 +388,25 @@ select_count(_, _) -> MatchSpec :: match_spec(), NumDeleted :: non_neg_integer(). -select_delete(_, _) -> +select_delete(Tab, [{'_',[],[true]}]) -> + ets:internal_delete_all(Tab, undefined); +select_delete(Tab, MatchSpec) -> + ets:internal_select_delete(Tab, MatchSpec). + +-spec internal_select_delete(Tab, MatchSpec) -> NumDeleted when + Tab :: tab(), + MatchSpec :: match_spec(), + NumDeleted :: non_neg_integer(). + +internal_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 @@ -486,12 +534,17 @@ update_counter(_, _, _, _) -> update_element(_, _, _) -> erlang:nif_error(undef). +-spec whereis(TableName) -> tid() | undefined when + TableName :: atom(). +whereis(_) -> + erlang:nif_error(undef). + %%% 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 +558,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 -> @@ -856,10 +909,10 @@ tab2file(Tab, File, Options) -> _ = disk_log:close(Name), _ = file:delete(File), exit(ExReason); - error:ErReason -> + error:ErReason:StackTrace -> _ = disk_log:close(Name), _ = file:delete(File), - erlang:raise(error,ErReason,erlang:get_stacktrace()) + erlang:raise(error,ErReason,StackTrace) end catch throw:TReason2 -> @@ -1034,9 +1087,9 @@ file2tab(File, Opts) -> exit:ExReason -> ets:delete(Tab), exit(ExReason); - error:ErReason -> + error:ErReason:StackTrace -> ets:delete(Tab), - erlang:raise(error,ErReason,erlang:get_stacktrace()) + erlang:raise(error,ErReason,StackTrace) end after _ = disk_log:close(Name) @@ -1667,13 +1720,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. @@ -1691,7 +1746,7 @@ get_line(P, Default) -> line_string(Binary) when is_binary(Binary) -> unicode:characters_to_list(Binary); line_string(Other) -> Other. -nonl(S) -> string:strip(S, right, $\n). +nonl(S) -> string:trim(S, trailing, "$\n"). print_number(Tab, Key, Num) -> Os = ets:lookup(Tab, Key), @@ -1720,7 +1775,7 @@ do_display_item(_Height, Width, I, Opos) -> L = to_string(I), L2 = if length(L) > Width - 8 -> - string:substr(L, 1, Width-13) ++ " ..."; + string:slice(L, 0, Width-13) ++ " ..."; true -> L end, diff --git a/lib/stdlib/src/eval_bits.erl b/lib/stdlib/src/eval_bits.erl index b3698fb3f5..bb86a65c72 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-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. @@ -25,6 +25,9 @@ -export([expr_grp/3,expr_grp/5,match_bits/6, match_bits/7,bin_gen/6]). +-define(STACKTRACE, + element(2, erlang:process_info(self(), current_stacktrace))). + %% Types used in this module: %% @type bindings(). An abstract structure for bindings between %% variables and values (the environment) @@ -67,16 +70,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]} = @@ -89,9 +96,9 @@ eval_exp_field1(V, Size, Unit, Type, Endian, Sign) -> eval_exp_field(V, Size, Unit, Type, Endian, Sign) catch error:system_limit -> - error(system_limit); + erlang:raise(error, system_limit, ?STACKTRACE); error:_ -> - error(badarg) + erlang:raise(error, badarg, ?STACKTRACE) end. eval_exp_field(Val, Size, Unit, integer, little, signed) -> @@ -127,7 +134,7 @@ eval_exp_field(Val, all, Unit, binary, _, _) -> Size when Size rem Unit =:= 0 -> <<Val:Size/binary-unit:1>>; _ -> - error(badarg) + erlang:raise(error, badarg, ?STACKTRACE) end; eval_exp_field(Val, Size, Unit, binary, _, _) -> <<Val:(Size*Unit)/binary-unit:1>>. @@ -373,12 +380,12 @@ make_bit_type(Line, default, Type0) -> {ok,all,Bt} -> {{atom,Line,all},erl_bits:as_list(Bt)}; {ok,undefined,Bt} -> {{atom,Line,undefined},erl_bits:as_list(Bt)}; {ok,Size,Bt} -> {{integer,Line,Size},erl_bits:as_list(Bt)}; - {error,Reason} -> error(Reason) + {error,Reason} -> erlang:raise(error, Reason, ?STACKTRACE) end; make_bit_type(_Line, Size, Type0) -> %Size evaluates to an integer or 'all' case erl_bits:set_bit_type(Size, Type0) of {ok,Size,Bt} -> {Size,erl_bits:as_list(Bt)}; - {error,Reason} -> error(Reason) + {error,Reason} -> erlang:raise(error, Reason, ?STACKTRACE) end. match_check_size(Mfun, Size, Bs) -> @@ -401,9 +408,3 @@ match_check_size(_, {value,_,_}, _Bs, _AllowAll) -> ok; %From the debugger. match_check_size(_, _, _Bs, _AllowAll) -> throw(invalid). - -%% error(Reason) -> exception thrown -%% Throw a nice-looking exception, similar to exceptions from erl_eval. -error(Reason) -> - erlang:raise(error, Reason, [{erl_eval,expr,3}]). - diff --git a/lib/stdlib/src/file_sorter.erl b/lib/stdlib/src/file_sorter.erl index 0d50392b96..191e050538 100644 --- a/lib/stdlib/src/file_sorter.erl +++ b/lib/stdlib/src/file_sorter.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2001-2016. All Rights Reserved. +%% Copyright Ericsson AB 2001-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. @@ -307,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) -> @@ -326,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 -> @@ -411,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 -> @@ -427,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. @@ -1311,15 +1309,14 @@ 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 -> error(Error, W1) - catch Class:Reason -> + catch Class:Reason:Stacktrace -> cleanup(W1), - erlang:raise(Class, Reason, erlang:get_stacktrace()) + erlang:raise(Class, Reason, Stacktrace) end. outfun(A, #w{inout_value = Val} = W) when Val =/= no_value -> @@ -1335,13 +1332,13 @@ 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) - catch Class:Reason -> + catch Class:Reason:Stacktrace -> cleanup(W1), - erlang:raise(Class, Reason, erlang:get_stacktrace()) + erlang:raise(Class, Reason, Stacktrace) end. is_keypos(Keypos) when is_integer(Keypos), Keypos > 0 -> @@ -1360,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). @@ -1380,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 @@ -1589,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 -> @@ -1602,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..de839be5cf 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]). @@ -364,11 +365,18 @@ do_list_dir(Dir, Mod) -> eval_list_dir(Dir, Mod). %%% Compiling a wildcard. + +%% Define characters used for escaping a \. +-define(ESCAPE_PREFIX, $@). +-define(ESCAPE_CHARACTER, [?ESCAPE_PREFIX,$e]). +-define(ESCAPED_ESCAPE_PREFIX, [?ESCAPE_PREFIX,?ESCAPE_PREFIX]). + %% Only for debugging. compile_wildcard(Pattern) when is_list(Pattern) -> {compiled_wildcard,?HANDLE_ERROR(compile_wildcard(Pattern, "."))}. -compile_wildcard(Pattern, Cwd0) -> +compile_wildcard(Pattern0, Cwd0) -> + Pattern = convert_escapes(Pattern0), [Root|Rest] = filename:split(Pattern), case filename:pathtype(Root) of relative -> @@ -408,7 +416,8 @@ compile_join({cwd,Cwd}, File0) -> compile_join({root,PrefixLen,Root}, File) -> {root,PrefixLen,filename:join(Root, File)}. -compile_part(Part) -> +compile_part(Part0) -> + Part = wrap_escapes(Part0), compile_part(Part, false, []). compile_part_to_sep(Part) -> @@ -444,6 +453,8 @@ compile_part([${|Rest], Upto, Result) -> error -> compile_part(Rest, Upto, [${|Result]) end; +compile_part([{escaped,X}|Rest], Upto, Result) -> + compile_part(Rest, Upto, [X|Result]); compile_part([X|Rest], Upto, Result) -> compile_part(Rest, Upto, [X|Result]); compile_part([], _Upto, Result) -> @@ -460,6 +471,8 @@ compile_charset1([Lower, $-, Upper|Rest], Ordset) when Lower =< Upper -> compile_charset1(Rest, compile_range(Lower, Upper, Ordset)); compile_charset1([$]|Rest], Ordset) -> {ok, {one_of, gb_sets:from_ordset(Ordset)}, Rest}; +compile_charset1([{escaped,X}|Rest], Ordset) -> + compile_charset1(Rest, ordsets:add_element(X, Ordset)); compile_charset1([X|Rest], Ordset) -> compile_charset1(Rest, ordsets:add_element(X, Ordset)); compile_charset1([], _Ordset) -> @@ -485,6 +498,32 @@ compile_alt(Pattern, Result) -> error end. +%% Convert backslashes to an illegal Unicode character to +%% protect in from filename:split/1. + +convert_escapes([?ESCAPE_PREFIX|T]) -> + ?ESCAPED_ESCAPE_PREFIX ++ convert_escapes(T); +convert_escapes([$\\|T]) -> + ?ESCAPE_CHARACTER ++ convert_escapes(T); +convert_escapes([H|T]) -> + [H|convert_escapes(T)]; +convert_escapes([]) -> + []. + +%% Wrap each escape in a tuple to remove the special meaning for +%% the character that follows. + +wrap_escapes(?ESCAPED_ESCAPE_PREFIX ++ T) -> + [?ESCAPE_PREFIX|wrap_escapes(T)]; +wrap_escapes(?ESCAPE_CHARACTER ++ [C|T]) -> + [{escaped,C}|wrap_escapes(T)]; +wrap_escapes(?ESCAPE_CHARACTER) -> + []; +wrap_escapes([H|T]) -> + [H|wrap_escapes(T)]; +wrap_escapes([]) -> + []. + badpattern(Reason) -> error({badpattern,Reason}). @@ -517,3 +556,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..b7b7b562ab 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-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. @@ -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 @@ -31,11 +34,46 @@ %% we flatten the arguments immediately on function entry as that makes %% it easier to ensure that the code works. +%% +%% *** Requirements on Raw Filename Format *** +%% +%% These requirements are due to the 'filename' module +%% in stdlib. This since it is documented that it +%% should be able to operate on raw filenames as well +%% as ordinary filenames. +%% +%% A raw filename *must* be a byte sequence where: +%% 1. Codepoints 0-127 (7-bit ascii) *must* be encoded +%% as a byte with the corresponding value. That is, +%% the most significant bit in the byte encoding the +%% codepoint is never set. +%% 2. Codepoints greater than 127 *must* be encoded +%% with the most significant bit set in *every* byte +%% encoding it. +%% +%% Latin1 and UTF-8 meet these requirements while +%% UTF-16 and UTF-32 don't. +%% +%% On Windows filenames are natively stored as malformed +%% UTF-16LE (lonely surrogates may appear). A more correct +%% description than UTF-16 would be an array of 16-bit +%% words... In order to meet the requirements of the +%% raw file format we convert the malformed UTF-16LE to +%% malformed UTF-8 which meet the requirements. +%% +%% Note that these requirements are today only OTP +%% internal (erts-stdlib internal) requirements that +%% could be changed. +%% + -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]). +-export([validate/1]). %% Undocumented and unsupported exports. -export([append/2]). @@ -139,6 +177,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 +472,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 +504,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 +518,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 +533,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 +724,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 +738,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 +804,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 +885,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 +901,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 +972,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 +1008,258 @@ filename_string_to_binary(List) -> Bin end. +%% Application Base Directories +%% basedir +%% http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html + +-type basedir_path_type() :: 'user_cache' | 'user_config' | 'user_data' + | 'user_log'. +-type basedir_paths_type() :: 'site_config' | 'site_data'. + +-type basedir_opts() :: #{author => string() | binary(), + os => 'windows' | 'darwin' | 'linux', + version => string() | binary()}. + +-spec basedir(PathType,Application) -> file:filename_all() when + PathType :: basedir_path_type(), + Application :: string() | binary(); + (PathsType,Application) -> [file:filename_all()] when + PathsType :: basedir_paths_type(), + Application :: string() | binary(). + +basedir(Type,Application) when is_atom(Type), is_list(Application) orelse + is_binary(Application) -> + basedir(Type, Application, #{}). + +-spec basedir(PathType,Application,Opts) -> file:filename_all() when + PathType :: basedir_path_type(), + Application :: string() | binary(), + Opts :: basedir_opts(); + (PathsType,Application,Opts) -> [file:filename_all()] when + PathsType :: basedir_paths_type(), + Application :: string() | binary(), + Opts :: basedir_opts(). + +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:lexemes(Base, ":"); + site_config -> + Base = getenv("XDG_CONFIG_DIRS",?basedir_linux_site_config,false), + string:lexemes(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. + +%% +%% validate/1 +%% + +-spec validate(FileName) -> boolean() when + FileName :: file:name_all(). + +validate(FileName) when is_binary(FileName) -> + %% Raw filename... + validate_bin(FileName); +validate(FileName) when is_list(FileName); + is_atom(FileName) -> + validate_list(FileName, + file:native_name_encoding(), + os:type()). + +validate_list(FileName, Enc, Os) -> + try + true = validate_list(FileName, Enc, Os, 0) > 0 + catch + _ : _ -> false + end. + +validate_list([], _Enc, _Os, Chars) -> + Chars; +validate_list(C, Enc, Os, Chars) when is_integer(C) -> + validate_char(C, Enc, Os), + Chars+1; +validate_list(A, Enc, Os, Chars) when is_atom(A) -> + validate_list(atom_to_list(A), Enc, Os, Chars); +validate_list([H|T], Enc, Os, Chars) -> + NewChars = validate_list(H, Enc, Os, Chars), + validate_list(T, Enc, Os, NewChars). + +%% C is always an integer... +% validate_char(C, _, _) when not is_integer(C) -> +% throw(invalid); +validate_char(C, _, _) when C < 1 -> + throw(invalid); %% No negative or null characters... +validate_char(C, latin1, _) when C > 255 -> + throw(invalid); +validate_char(C, utf8, _) when C >= 16#110000 -> + throw(invalid); +validate_char(C, utf8, {win32, _}) when C > 16#ffff -> + throw(invalid); %% invalid win wchar... +validate_char(_C, utf8, {win32, _}) -> + ok; %% Range below is accepted on windows... +validate_char(C, utf8, _) when 16#D800 =< C, C =< 16#DFFF -> + throw(invalid); %% invalid unicode range... +validate_char(_, _, _) -> + ok. + +validate_bin(Bin) -> + %% Raw filename. That is, we do not interpret + %% the encoding, but we still do not accept + %% null characters... + try + true = validate_bin(Bin, 0) > 0 + catch + _ : _ -> false + end. + +validate_bin(<<>>, Bs) -> + Bs; +validate_bin(<<0, _Rest/binary>>, _Bs) -> + throw(invalid); %% No null characters allowed... +validate_bin(<<_B, Rest/binary>>, Bs) -> + validate_bin(Rest, Bs+1). 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..a7f743bd4c 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-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. @@ -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]). @@ -48,6 +49,7 @@ | {'logfile', string()}. -type option() :: {'timeout', timeout()} | {'debug', [debug_flag()]} + | {'hibernate_after', timeout()} | {'spawn_opt', [proc_lib:spawn_option()]}. -type options() :: [option()]. @@ -124,7 +126,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} -> @@ -146,57 +148,36 @@ init_it2(GenMod, Starter, Parent, Name, Mod, Args, Options) -> call(Process, Label, Request) -> call(Process, Label, Request, ?default_timeout). +%% Optimize a common case. +call(Process, Label, Request, Timeout) when is_pid(Process), + Timeout =:= infinity orelse is_integer(Timeout) andalso Timeout >= 0 -> + do_call(Process, Label, Request, Timeout); call(Process, Label, Request, Timeout) when Timeout =:= infinity; is_integer(Timeout), Timeout >= 0 -> Fun = fun(Pid) -> do_call(Pid, Label, Request, Timeout) end, do_for_proc(Process, Fun). -do_call(Process, Label, Request, Timeout) -> - try erlang:monitor(process, Process) of - Mref -> - %% If the monitor/2 call failed to set up a connection to a - %% remote node, we don't want the '!' operator to attempt - %% to set up the connection again. (If the monitor/2 call - %% failed due to an expired timeout, '!' too would probably - %% have to wait for the timeout to expire.) Therefore, - %% use erlang:send/3 with the 'noconnect' option so that it - %% will fail immediately if there is no connection to the - %% remote node. - - catch erlang:send(Process, {Label, {self(), Mref}, Request}, - [noconnect]), - receive - {Mref, Reply} -> - erlang:demonitor(Mref, [flush]), - {ok, Reply}; - {'DOWN', Mref, _, _, noconnection} -> - Node = get_node(Process), - exit({nodedown, Node}); - {'DOWN', Mref, _, _, Reason} -> - exit(Reason) - after Timeout -> - erlang:demonitor(Mref, [flush]), - exit(timeout) - end - catch - error:_ -> - %% Node (C/Java?) is not supporting the monitor. - %% The other possible case -- this node is not distributed - %% -- should have been handled earlier. - %% Do the best possible with monitor_node/2. - %% This code may hang indefinitely if the Process - %% does not exist. It is only used for featureweak remote nodes. - Node = get_node(Process), - monitor_node(Node, true), - receive - {nodedown, Node} -> - monitor_node(Node, false), - exit({nodedown, Node}) - after 0 -> - Tag = make_ref(), - Process ! {Label, {self(), Tag}, Request}, - wait_resp(Node, Tag, Timeout) - end +do_call(Process, Label, Request, Timeout) when is_atom(Process) =:= false -> + Mref = erlang:monitor(process, Process), + + %% OTP-21: + %% Auto-connect is asynchronous. But we still use 'noconnect' to make sure + %% we send on the monitored connection, and not trigger a new auto-connect. + %% + erlang:send(Process, {Label, {self(), Mref}, Request}, [noconnect]), + + receive + {Mref, Reply} -> + erlang:demonitor(Mref, [flush]), + {ok, Reply}; + {'DOWN', Mref, _, _, noconnection} -> + Node = get_node(Process), + exit({nodedown, Node}); + {'DOWN', Mref, _, _, Reason} -> + exit(Reason) + after Timeout -> + erlang:demonitor(Mref, [flush]), + exit(timeout) end. get_node(Process) -> @@ -211,19 +192,6 @@ get_node(Process) -> node(Process) end. -wait_resp(Node, Tag, Timeout) -> - receive - {Tag, Reply} -> - monitor_node(Node, false), - {ok, Reply}; - {nodedown, Node} -> - monitor_node(Node, false), - exit({nodedown, Node}) - after Timeout -> - monitor_node(Node, false), - exit(timeout) - end. - %% %% Send a reply to the client. %% @@ -297,19 +265,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 +285,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..8213282867 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, @@ -45,16 +47,19 @@ system_replace_state/2, format_status/2]). +%% logger callback +-export([format_log/1]). + -export_type([handler/0, handler_args/0, add_handler_ret/0, del_handler_ret/0]). --import(error_logger, [error_msg/2]). - -record(handler, {module :: atom(), id = false, state, supervised = false :: 'false' | pid()}). +-include("logger.hrl"). + %%%========================================================================= %%% API %%%========================================================================= @@ -107,7 +112,8 @@ State :: term(), Status :: term(). --optional_callbacks([format_status/2]). +-optional_callbacks( + [handle_info/2, terminate/2, code_change/3, format_status/2]). %%--------------------------------------------------------------------------- @@ -116,46 +122,77 @@ -type add_handler_ret() :: ok | term() | {'EXIT',term()}. -type del_handler_ret() :: ok | term() | {'EXIT',term()}. --type emgr_name() :: {'local', atom()} | {'global', atom()} - | {'via', atom(), term()}. --type emgr_ref() :: atom() | {atom(), atom()} | {'global', atom()} - | {'via', atom(), term()} | pid(). +-type emgr_name() :: {'local', atom()} | {'global', 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', term()} + | {'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, term()} | {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 +202,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 +235,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 +269,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 +399,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 +419,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 +436,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 +445,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 +465,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 +490,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 +498,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 +555,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 +575,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 +585,14 @@ server_update(Handler1, Func, Event, SName) -> do_terminate(Mod1, Handler1, remove_handler, State, remove, SName, normal), no; + {'EXIT', {undef, [{Mod1, handle_info, [_,_], _}|_]}} -> + ?LOG_WARNING(#{label=>{gen_event,no_handle_info}, + module=>Mod1, + message=>Event}, + #{domain=>[otp], + report_cb=>fun gen_event:format_log/1, + error_logger=>#{tag=>warning_msg}}), % warningmap?? + {ok, Handler1}; Other -> do_terminate(Mod1, Handler1, {error, Other}, State, Event, SName, crash), @@ -649,14 +696,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 +714,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 +744,24 @@ report_error(_Handler, normal, _, _, _) -> ok; report_error(_Handler, shutdown, _, _, _) -> ok; report_error(_Handler, {swapped,_,_}, _, _, _) -> ok; report_error(Handler, Reason, State, LastIn, SName) -> - Reason1 = + ?LOG_ERROR(#{label=>{gen_event,terminate}, + handler=>handler(Handler), + name=>SName, + last_message=>LastIn, + state=>format_status(terminate,Handler#handler.module, + get(),State), + reason=>Reason}, + #{domain=>[otp], + report_cb=>fun gen_event:format_log/1, + error_logger=>#{tag=>error}}). + +format_log(#{label:={gen_event,terminate}, + handler:=Handler, + name:=SName, + last_message:=LastIn, + state:=State, + reason:=Reason}) -> + Reason1 = case Reason of {'EXIT',{undef,[{M,F,A,L}|MFAs]}} -> case code:is_loaded(M) of @@ -710,23 +780,18 @@ report_error(Handler, Reason, State, LastIn, SName) -> _ -> Reason end, - Mod = Handler#handler.module, - FmtState = case erlang:function_exported(Mod, format_status, 2) of - true -> - Args = [get(), State], - case catch Mod:format_status(terminate, Args) of - {'EXIT', _} -> State; - Else -> Else - end; - _ -> - 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", - [handler(Handler),SName,LastIn,FmtState,Reason1]). + {"** gen_event handler ~p crashed.~n" + "** Was installed in ~tp~n" + "** Last event was: ~tp~n" + "** When handler state == ~tp~n" + "** Reason == ~tp~n", + [Handler,SName,LastIn,State,Reason1]}; +format_log(#{label:={gen_event,no_handle_info}, + module:=Mod, + message:=Msg}) -> + {"** Undefined handle_info in ~tp~n" + "** Unhandled message: ~tp~n", + [Mod, Msg]}. handler(Handler) when not Handler#handler.id -> Handler#handler.module; @@ -747,7 +812,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,20 +821,24 @@ 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 - true -> - Args = [PDict, State], - case catch Mod:format_status(Opt, Args) of - {'EXIT', _} -> MSL; - Else -> MS#handler{state = Else} - end; - _ -> - MS - end || #handler{module = Mod, state = State} = MS <- MSL], + FmtMSL = [MS#handler{state=format_status(Opt, Mod, PDict, State)} + || #handler{module = Mod, state = State} = MS <- MSL], [{header, Header}, {data, [{"Status", SysState}, {"Parent", Parent}]}, {items, {"Installed handlers", FmtMSL}}]. + +format_status(Opt, Mod, PDict, State) -> + case erlang:function_exported(Mod, format_status, 2) of + true -> + Args = [PDict, State], + case catch Mod:format_status(Opt, Args) of + {'EXIT', _} -> State; + Else -> Else + end; + false -> + State + end. diff --git a/lib/stdlib/src/gen_fsm.erl b/lib/stdlib/src/gen_fsm.erl index 7eabb95548..caaaf8fa2e 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. @@ -105,6 +105,8 @@ %%% %%% --------------------------------------------------- +-include("logger.hrl"). + -export([start/3, start/4, start_link/3, start_link/4, stop/1, stop/3, @@ -113,7 +115,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,7 +126,28 @@ system_replace_state/2, format_status/2]). --import(error_logger, [format/2]). +%% logger callback +-export([format_log/1]). + +-deprecated({start, 3, eventually}). +-deprecated({start, 4, eventually}). +-deprecated({start_link, 3, eventually}). +-deprecated({start_link, 4, eventually}). +-deprecated({stop, 1, eventually}). +-deprecated({stop, 3, eventually}). +-deprecated({send_event, 2, eventually}). +-deprecated({sync_send_event, 2, eventually}). +-deprecated({sync_send_event, 3, eventually}). +-deprecated({send_all_state_event, 2, eventually}). +-deprecated({sync_send_all_state_event, 2, eventually}). +-deprecated({sync_send_all_state_event, 3, eventually}). +-deprecated({reply, 2, eventually}). +-deprecated({start_timer, 2, eventually}). +-deprecated({send_event_after, 2, eventually}). +-deprecated({cancel_timer, 1, eventually}). +-deprecated({enter_loop, 4, eventually}). +-deprecated({enter_loop, 5, eventually}). +-deprecated({enter_loop, 6, eventually}). %%% --------------------------------------------------- %%% Interface functions. @@ -169,7 +192,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 +201,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 +297,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 +329,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 +345,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 +373,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 +455,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 +501,14 @@ handle_msg(Msg, Parent, Name, StateName, StateData, Mod, _Time) -> %No debug her StateName, NStateData, [])), reply(From, Reply), exit(R); + {'EXIT', {undef, [{Mod, handle_info, [_,_,_], _}|_]}} -> + ?LOG_WARNING(#{label=>{gen_fsm,no_handle_info}, + module=>Mod, + message=>Msg}, + #{domain=>[otp], + report_cb=>fun gen_fsm:format_log/1, + error_logger=>#{tag=>warning_msg}}), + loop(Parent, Name, StateName, StateData, Mod, infinity, HibernateAfterTimeout, []); {'EXIT', What} -> terminate(What, Name, Msg, Mod, StateName, StateData, []); Reply -> @@ -540,23 +516,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,27 +583,51 @@ 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) -> + ?LOG_ERROR(#{label=>{gen_fsm,terminate}, + name=>Name, + last_message=>Msg, + state_name=>StateName, + state_data=>StateData, + reason=>Reason}, + #{domain=>[otp], + report_cb=>fun gen_fsm:format_log/1, + error_logger=>#{tag=>error}}), + sys:print_log(Debug), + ok. + +format_log(#{label:={gen_fsm,terminate}, + name:=Name, + last_message:=Msg, + state_name:=StateName, + state_data:=StateData, + reason:=Reason}) -> Reason1 = case Reason of {undef,[{M,F,A,L}|MFAs]} -> @@ -645,29 +645,33 @@ error_info(Reason, Name, Msg, StateName, StateData, Debug) -> _ -> Reason end, - Str = "** State machine ~p terminating \n" ++ - get_msg_str(Msg) ++ - "** When State == ~p~n" - "** Data == ~p~n" - "** Reason for termination = ~n** ~p~n", - format(Str, [Name, get_msg(Msg), StateName, StateData, Reason1]), - sys:print_log(Debug), - ok. + {"** State machine ~tp terminating \n" ++ + get_msg_str(Msg) ++ + "** When State == ~tp~n" + "** Data == ~tp~n" + "** Reason for termination = ~n** ~tp~n", + [Name, get_msg(Msg), StateName, StateData, Reason1]}; +format_log(#{label:={gen_fsm,no_handle_info}, + module:=Mod, + message:=Msg}) -> + {"** Undefined handle_info in ~p~n" + "** Unhandled message: ~tp~n", + [Mod, Msg]}. 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 +685,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..44e9231ebe 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-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. @@ -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, @@ -104,33 +104,44 @@ system_replace_state/2, format_status/2]). +%% logger callback +-export([format_log/1]). + %% Internal exports -export([init_it/6]). --import(error_logger, [format/2]). +-include("logger.hrl"). + +-define( + STACKTRACE(), + element(2, erlang:process_info(self(), current_stacktrace))). %%%========================================================================= %%% API %%%========================================================================= -callback init(Args :: term()) -> - {ok, State :: term()} | {ok, State :: term(), timeout() | hibernate} | + {ok, State :: term()} | {ok, State :: term(), timeout() | hibernate | {continue, term()}} | {stop, Reason :: term()} | ignore. -callback handle_call(Request :: term(), From :: {pid(), Tag :: term()}, State :: term()) -> {reply, Reply :: term(), NewState :: term()} | - {reply, Reply :: term(), NewState :: term(), timeout() | hibernate} | + {reply, Reply :: term(), NewState :: term(), timeout() | hibernate | {continue, term()}} | {noreply, NewState :: term()} | - {noreply, NewState :: term(), timeout() | hibernate} | + {noreply, NewState :: term(), timeout() | hibernate | {continue, term()}} | {stop, Reason :: term(), Reply :: term(), NewState :: term()} | {stop, Reason :: term(), NewState :: term()}. -callback handle_cast(Request :: term(), State :: term()) -> {noreply, NewState :: term()} | - {noreply, NewState :: term(), timeout() | hibernate} | + {noreply, NewState :: term(), timeout() | hibernate | {continue, term()}} | {stop, Reason :: term(), NewState :: term()}. -callback handle_info(Info :: timeout | term(), State :: term()) -> {noreply, NewState :: term()} | - {noreply, NewState :: term(), timeout() | hibernate} | + {noreply, NewState :: term(), timeout() | hibernate | {continue, term()}} | + {stop, Reason :: term(), NewState :: term()}. +-callback handle_continue(Info :: term(), State :: term()) -> + {noreply, NewState :: term()} | + {noreply, NewState :: term(), timeout() | hibernate | {continue, term()}} | {stop, Reason :: term(), NewState :: term()}. -callback terminate(Reason :: (normal | shutdown | {shutdown, term()} | term()), @@ -146,8 +157,8 @@ State :: term(), Status :: term(). --optional_callbacks([format_status/2]). - +-optional_callbacks( + [handle_info/2, handle_continue/2, terminate/2, code_change/3, format_status/2]). %%% ----------------------------------------------------------------- %%% Starts a generic server. @@ -155,7 +166,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' server %%% Args ::= term(), init arguments (to Mod:init/1) %%% Options ::= [{timeout, Timeout} | {debug, [Flag]}] @@ -304,10 +315,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,102 +335,118 @@ 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:S -> {'EXIT', Class, R, S} 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, {continue, Continue} = Msg, HibernateAfterTimeout, Debug) -> + Reply = try_dispatch(Mod, handle_continue, Continue, State), + case Debug of + [] -> + handle_common_reply(Reply, Parent, Name, undefined, Msg, Mod, + HibernateAfterTimeout, State); + _ -> + Debug1 = sys:handle_debug(Debug, fun print_event/3, Name, Msg), + handle_common_reply(Reply, Parent, Name, undefined, Msg, Mod, + HibernateAfterTimeout, State, Debug1) + end; + +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. %%% --------------------------------------------------- %%% Send/receive functions %%% --------------------------------------------------- do_send(Dest, Msg) -> - case catch erlang:send(Dest, Msg, [noconnect]) of - noconnect -> - spawn(erlang, send, [Dest,Msg]); - Other -> - Other - end. + try erlang:send(Dest, Msg) + catch + error:_ -> ok + end, + ok. do_multi_call(Nodes, Name, Req, infinity) -> Tag = make_ref(), @@ -592,17 +620,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 +638,22 @@ 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:Stacktrace when Func == handle_info -> + case erlang:function_exported(Mod, handle_info, 2) of + false -> + ?LOG_WARNING( + #{label=>{gen_server,no_handle_info}, + module=>Mod, + message=>Msg}, + #{domain=>[otp], + report_cb=>fun gen_server:format_log/1, + error_logger=>#{tag=>warning_msg}}), + {ok, {noreply, State}}; + true -> + {'EXIT', error, R, Stacktrace} + end; + Class:R:Stacktrace -> + {'EXIT', Class, R, Stacktrace} end. try_handle_call(Mod, Msg, From, State) -> @@ -630,26 +662,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:Stacktrace -> + {'EXIT', Class, R, 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:Stacktrace -> + {'EXIT', Class, R, Stacktrace} + end; + false -> + {ok, ok} end. @@ -657,89 +686,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 +782,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 +810,115 @@ 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} -> - FmtState = format_status(terminate, Mod, get(), State), - error_info(ReportReason1, Name, Msg, FmtState, Debug), - exit(ExitReason1); + {'EXIT', C, R, S} -> + error_info({R, S}, Name, From, Msg, Mod, State, 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, Mod, State, 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, _Mod, _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, Mod, State, Debug) -> + ?LOG_ERROR(#{label=>{gen_server,terminate}, + name=>Name, + last_message=>Msg, + state=>format_status(terminate, Mod, get(), State), + reason=>Reason, + client_info=>client_stacktrace(From)}, + #{domain=>[otp], + report_cb=>fun gen_server:format_log/1, + error_logger=>#{tag=>error}}), + sys:print_log(Debug), + ok. + +client_stacktrace(undefined) -> + 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 -> + {From,dead}; + [{current_stacktrace, Stacktrace}, {registered_name, []}] -> + {From,{From,Stacktrace}}; + [{current_stacktrace, Stacktrace}, {registered_name, Name}] -> + {From,{Name,Stacktrace}} + end; +client_stacktrace(From) when is_pid(From) -> + {From,remote}. + +format_log(#{label:={gen_server,terminate}, + name:=Name, + last_message:=Msg, + state:=State, + reason:=Reason, + client_info:=Client}) -> Reason1 = case Reason of {undef,[{M,F,A,L}|MFAs]} -> @@ -848,101 +934,37 @@ 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]), - 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) - 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. + {ClientFmt,ClientArgs} = format_client_log(Client), + {"** 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, error_logger:limit_term(State), Reason1] ++ ClientArgs}; +format_log(#{label:={gen_server,no_handle_info}, + module:=Mod, + message:=Msg}) -> + {"** Undefined handle_info in ~p~n" + "** Unhandled message: ~tp~n", + [Mod, Msg]}. + +format_client_log(undefined) -> + {"", []}; +format_client_log({From,dead}) -> + {"** Client ~p is dead~n", [From]}; +format_client_log({From,remote}) -> + {"** Client ~p is remote on node ~p~n", [From, node(From)]}; +format_client_log({_From,{Name,Stacktrace}}) -> + {"** Client ~tp stacktrace~n" + "** ~tp~n", + [Name, Stacktrace]}. %%----------------------------------------------------------------- %% 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..faa43fbc1e --- /dev/null +++ b/lib/stdlib/src/gen_statem.erl @@ -0,0 +1,2044 @@ +%% +%% %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). + +-include("logger.hrl"). + +%% 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]). + +%% logger callback +-export([format_log/1]). + +%% 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() :: + (Time :: event_timeout()) | % {timeout,Time,Time} + {'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 preferred +%% 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, + event_type/1, from/1, timeout_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. +%% +event_type(Type) -> + case Type of + {call,From} -> from(From); + %% + cast -> true; + info -> true; + internal -> true; + _ -> timeout_event_type(Type) + end. +%% +from({Pid,_}) when is_pid(Pid) -> true; +from(_) -> false. +%% +timeout_event_type(Type) -> + case Type of + timeout -> true; + state_timeout -> true; + {timeout,_Name} -> true; + _ -> false + end. + + +-define( + STACKTRACE(), + element(2, erlang:process_info(self(), current_stacktrace))). + +-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, 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:Stacktrace -> + erlang:raise( + Class, + {Reason,{?MODULE,call,[ServerRef,Request,Timeout]}}, + 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:Stacktrace -> + {Ref,Class,Reason,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) + catch + error:_ -> ok + end, + ok. + +%% 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 -> + 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}, + []), + 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}, + []), + 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,_NextState,_NewData} -> + terminate( + error, + {bad_state_enter_return_from_state_function,Result}, + ?STACKTRACE(), Debug, + S#state{ + state = State, data = Data, + hibernate = hibernate_in_trans_opts(TransOpts)}, + [Event|Events]); + {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); + {next_state,_NextState,_NewData,_Actions} -> + terminate( + error, + {bad_state_enter_return_from_state_function,Result}, + ?STACKTRACE(), Debug, + S#state{ + state = State, data = Data, + hibernate = hibernate_in_trans_opts(TransOpts)}, + [Event|Events]); + %% + {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. + +%% 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 = 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. + +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}); + postpone -> + [error, + {bad_state_enter_action_from_state_function,Action}, + ?STACKTRACE(), + Debug]; + %% + {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_state_enter_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_state_enter_action_from_state_function, + {next_event,Type,Content}}, + ?STACKTRACE(), + Debug] + end. + +parse_actions_timeout( + StateCall, Debug, S, Actions, TransOpts, + {TimeoutType,Time,TimerMsg,TimerOpts} = AbsoluteTimeout) -> + %% + case classify_timeout(TimeoutType, Time, listify(TimerOpts)) of + absolute -> + parse_actions_timeout_add( + StateCall, Debug, S, Actions, + TransOpts, AbsoluteTimeout); + relative -> + RelativeTimeout = {TimeoutType,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, + {TimeoutType,Time,_} = RelativeTimeout) -> + case classify_timeout(TimeoutType, 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, + Time) -> + case classify_timeout(timeout, Time, []) of + relative -> + RelativeTimeout = {timeout,Time,Time}, + parse_actions_timeout_add( + StateCall, Debug, S, Actions, + TransOpts, RelativeTimeout); + badarg -> + [error, + {bad_action_from_state_function,Time}, + ?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,NextState}), + Event_0|P_0]; + false -> + [?sys_debug( + Debug_0, + {S#state.name,State}, + {consume,Event_0,NextState})|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:Stacktrace -> + [Class,Reason,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:Stacktrace -> + [Class,Reason,Stacktrace] + end. + + +%% -> absolute | relative | badarg +classify_timeout(TimeoutType, Time, Opts) -> + case timeout_event_type(TimeoutType) of + true -> + classify_time(false, Time, Opts); + false -> + badarg + end. + +classify_time(Abs, Time, []) -> + case Abs of + true when + is_integer(Time); + Time =:= infinity -> + absolute; + false when + is_integer(Time), 0 =< Time; + Time =:= infinity -> + relative; + _ -> + badarg + end; +classify_time(_, Time, [{abs,Abs}|Opts]) when is_boolean(Abs) -> + classify_time(Abs, Time, Opts); +classify_time(_, _, 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, []) + 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 -> + error_info(C, R, ST, S, Q), + 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), + 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} = S, + Q) -> + ?LOG_ERROR(#{label=>{gen_statem,terminate}, + name=>Name, + queue=>Q, + postponed=>P, + callback_mode=>CallbackMode, + state_enter=>StateEnter, + state=>format_status(terminate, get(), S), + reason=>{Class,Reason,Stacktrace}}, + #{domain=>[otp], + report_cb=>fun gen_statem:format_log/1, + error_logger=>#{tag=>error}}). + +format_log(#{label:={gen_statem,terminate}, + name:=Name, + queue:=Q, + postponed:=P, + callback_mode:=CallbackMode, + state_enter:=StateEnter, + state:=FmtData, + reason:={Class,Reason,Stacktrace}}) -> + {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, + {"** 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..63c9a6bddf 100644 --- a/lib/stdlib/src/io.erl +++ b/lib/stdlib/src/io.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. @@ -86,7 +86,16 @@ put_chars(Chars) -> CharData :: unicode:chardata(). put_chars(Io, Chars) -> - o_request(Io, {put_chars,unicode,Chars}, put_chars). + put_chars(Io, unicode, Chars). + +%% This function is here to make the erlang:raise in o_request actually raise to +%% a valid function. +-spec put_chars(IoDevice, Encoding, CharData) -> 'ok' when + IoDevice :: device(), + Encoding :: unicode, + CharData :: unicode:chardata(). +put_chars(Io, Encoding, Chars) -> + o_request(Io, {put_chars,Encoding,Chars}, put_chars). -spec nl() -> 'ok'. @@ -444,7 +453,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 +640,20 @@ io_requests(Pid, [], [Rs|Cont], Tail) -> io_requests(_Pid, [], [], _Tail) -> {false,[]}. - -bc_req(Pid,{Op,Enc,Param},MaybeConvert) -> +bc_req(Pid, Req0, MaybeConvert) -> case net_kernel:dflag_unicode_io(Pid) of true -> - {false,{Op,Enc,Param}}; + %% The most common case. A modern i/o server. + {false,Req0}; 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) -> - case net_kernel:dflag_unicode_io(Pid) of - true -> - {false,{Op,Enc,M,F,A}}; - 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..8223a52873 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 @@ -60,16 +60,17 @@ -module(io_lib). --export([fwrite/2,fread/2,fread/3,format/2]). --export([scan_format/2,unscan_format/1,build_text/1]). +-export([fwrite/2,fwrite/3,fread/2,fread/3,format/2,format/3]). +-export([scan_format/2,unscan_format/1,build_text/1,build_text/2]). -export([print/1,print/4,indentation/2]). -export([write/1,write/2,write/3,nl/0,format_prompt/1,format_prompt/2]). +-export([write_binary/3]). -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,8 +85,10 @@ -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]). + fread_error/0, fread_item/0, format_spec/0, chars_limit/0]). %%---------------------------------------------------------------------- @@ -112,14 +115,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() }. %%---------------------------------------------------------------------- @@ -133,6 +136,18 @@ fwrite(Format, Args) -> format(Format, Args). +-type chars_limit() :: integer(). + +-spec fwrite(Format, Data, Options) -> chars() when + Format :: io:format(), + Data :: [term()], + Options :: [Option], + Option :: {'chars_limit', CharsLimit}, + CharsLimit :: chars_limit(). + +fwrite(Format, Args, Options) -> + format(Format, Args, Options). + -spec fread(Format, String) -> Result when Format :: string(), String :: string(), @@ -147,7 +162,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()}, @@ -163,11 +178,26 @@ fread(Cont, Chars, Format) -> Data :: [term()]. format(Format, Args) -> - case catch io_lib_format:fwrite(Format, Args) of - {'EXIT',_} -> - erlang:error(badarg, [Format, Args]); - Other -> - Other + try io_lib_format:fwrite(Format, Args) + catch + C:R:S -> + test_modules_loaded(C, R, S), + erlang:error(badarg, [Format, Args]) + end. + +-spec format(Format, Data, Options) -> chars() when + Format :: io:format(), + Data :: [term()], + Options :: [Option], + Option :: {'chars_limit', CharsLimit}, + CharsLimit :: chars_limit(). + +format(Format, Args, Options) -> + try io_lib_format:fwrite(Format, Args, Options) + catch + C:R:S -> + test_modules_loaded(C, R, S), + erlang:error(badarg, [Format, Args]) end. -spec scan_format(Format, Data) -> FormatList when @@ -178,7 +208,9 @@ format(Format, Args) -> scan_format(Format, Args) -> try io_lib_format:scan(Format, Args) catch - _:_ -> erlang:error(badarg, [Format, Args]) + C:R:S -> + test_modules_loaded(C, R, S), + erlang:error(badarg, [Format, Args]) end. -spec unscan_format(FormatList) -> {Format, Data} when @@ -193,7 +225,37 @@ unscan_format(FormatList) -> FormatList :: [char() | format_spec()]. build_text(FormatList) -> - io_lib_format:build(FormatList). + try io_lib_format:build(FormatList) + catch + C:R:S -> + test_modules_loaded(C, R, S), + erlang:error(badarg, [FormatList]) + end. + +-spec build_text(FormatList, Options) -> chars() when + FormatList :: [char() | format_spec()], + Options :: [Option], + Option :: {'chars_limit', CharsLimit}, + CharsLimit :: chars_limit(). + +build_text(FormatList, Options) -> + try io_lib_format:build(FormatList, Options) + catch + C:R:S -> + test_modules_loaded(C, R, S), + erlang:error(badarg, [FormatList, Options]) + end. + +%% Failure to load a module must not be labeled as badarg. +%% C, R, and S are included so that the original error, which could be +%% a bug in io_lib_format, can be found by tracing on +%% test_modules_loaded/3. +test_modules_loaded(_C, _R, _S) -> + Modules = [io_lib_format, io_lib_pretty, string, unicode], + case code:ensure_modules_loaded(Modules) of + ok -> ok; + Error -> erlang:error(Error) + end. -spec print(Term) -> chars() when Term :: term(). @@ -238,7 +300,7 @@ format_prompt(Prompt, Encoding) -> do_format_prompt(add_modifier(Encoding, "p"), [Prompt]). do_format_prompt(Format, Args) -> - case catch io_lib:format(Format, Args) of + case catch format(Format, Args) of {'EXIT',_} -> "???"; List -> List end. @@ -257,7 +319,8 @@ add_modifier(_, C) -> -spec write(Term) -> chars() when Term :: term(). -write(Term) -> write(Term, -1). +write(Term) -> + write1(Term, -1, latin1). -spec write(term(), depth(), boolean()) -> chars(). @@ -268,47 +331,78 @@ write(Term, D, false) -> -spec write(Term, Depth) -> chars() when Term :: term(), + Depth :: depth(); + (Term, Options) -> chars() when + Term :: term(), + Options :: [Option], + Option :: {'chars_limit', CharsLimit} + | {'depth', Depth} + | {'encoding', 'latin1' | 'utf8' | 'unicode'}, + CharsLimit :: chars_limit(), 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()), + CharsLimit = get_option(chars_limit, Options, -1), + if + Depth =:= 0; CharsLimit =:= 0 -> + "..."; + CharsLimit < 0 -> + write1(Term, Depth, Encoding); + CharsLimit > 0 -> + RecDefFun = fun(_, _) -> no end, + If = io_lib_pretty:intermediate + (Term, Depth, CharsLimit, RecDefFun, Encoding, _Str=false), + io_lib_pretty:write(If) + end; +write(Term, Depth) -> + write(Term, [{depth, Depth}, {encoding, 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_tuple(T, 2, D-1, E)], $}] end. -%% write_tail(List, Depth, CharacterBeforeDots) +%% write_tail(List, Depth, Encoding) %% 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) -> ""; +write_tail(_, 1, _E) -> [$| | "..."]; +write_tail([H|T], D, E) -> + [$,,write1(H, D-1, E)|write_tail(T, D-1, E)]; +write_tail(Other, D, E) -> + [$|,write1(Other, D-1, E)]. + +write_tuple(T, I, _D, _E) when I > tuple_size(T) -> ""; +write_tuple(_, _I, 1, _E) -> [$, | "..."]; +write_tuple(T, I, D, E) -> + [$,,write1(element(I, T), D-1, E)|write_tuple(T, I+1, D-1, E)]. write_port(Port) -> erlang:port_to_list(Port). @@ -316,33 +410,56 @@ 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, D - 1, 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(_, 1, _D0, _E) -> "..."; +write_map_body([], _, _D0, _E) -> []; +write_map_body([{K,V}], _D, D0, E) -> write_map_assoc(K, V, D0, E); +write_map_body([{K,V}|KVs], D, D0, E) -> + [write_map_assoc(K, V, D0, E),$, | write_map_body(KVs, D - 1, D0, 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, E)," => ",write1(V, D, E)]. write_binary(B, D) when is_integer(D) -> - [$<,$<,write_binary_body(B, D),$>,$>]. - -write_binary_body(<<>>, _D) -> - ""; -write_binary_body(_B, 1) -> - "..."; -write_binary_body(<<X:8>>, _D) -> - [integer_to_list(X)]; -write_binary_body(<<X:8,Rest/bitstring>>, D) -> - [integer_to_list(X),$,|write_binary_body(Rest, D-1)]; -write_binary_body(B, _D) -> + {S, _} = write_binary(B, D, -1), + S. + +write_binary(B, D, T) -> + {S, Rest} = write_binary_body(B, D, tsub(T, 4), []), + {[$<,$<,lists:reverse(S),$>,$>], Rest}. + +write_binary_body(<<>> = B, _D, _T, Acc) -> + {Acc, B}; +write_binary_body(B, D, T, Acc) when D =:= 1; T =:= 0-> + {["..."|Acc], B}; +write_binary_body(<<X:8>>, _D, _T, Acc) -> + {[integer_to_list(X)|Acc], <<>>}; +write_binary_body(<<X:8,Rest/bitstring>>, D, T, Acc) -> + S = integer_to_list(X), + write_binary_body(Rest, D-1, tsub(T, length(S) + 1), [$,,S|Acc]); +write_binary_body(B, _D, _T, Acc) -> L = bit_size(B), <<X:L>> = B, - [integer_to_list(X),$:,integer_to_list(L)]. + {[integer_to_list(L),$:,integer_to_list(X)|Acc], <<>>}. + +%% Make sure T does not change sign. +tsub(T, _) when T < 0 -> T; +tsub(T, E) when T >= E -> T - E; +tsub(_, _) -> 0. + +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 +468,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 +1002,132 @@ 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_tuple(T, 2, 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). + +limit_tuple(T, I, _D) when I > tuple_size(T) -> []; +limit_tuple(_, _I, 1) -> ['...']; +limit_tuple(T, I, D) -> + [limit(element(I, T), D-1)|limit_tuple(T, I+1, 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. Instead of subtracting one +%% from the depth as the map associations are traversed (as is done +%% for tuples and lists), the same depth is applied to each and every +%% (returned) association. +limit_map(Map, D) -> + %% Keep one extra association to make sure the final ',...' is included. + limit_map_body(maps:iterator(Map), D + 1, D, []). + +limit_map_body(_I, 0, _D0, Acc) -> + maps:from_list(Acc); +limit_map_body(I, D, D0, Acc) -> + case maps:next(I) of + {K, V, NextI} -> + limit_map_body(NextI, D-1, D0, [limit_map_assoc(K, V, D0) | Acc]); + none -> + maps:from_list(Acc) + end. + +limit_map_assoc(K, V, D) -> + %% Keep keys as are to avoid creating duplicated keys. + {K, 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) -> + test_limit_map_body(maps:iterator(Map), D). + +test_limit_map_body(_I, 0) -> throw(limit); % cannot happen +test_limit_map_body(I, D) -> + case maps:next(I) of + {K, V, NextI} -> + test_limit_map_assoc(K, V, D), + test_limit_map_body(NextI, D-1); + none -> + ok + end. + +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..ab9031573b 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-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. @@ -21,7 +21,8 @@ %% Formatting functions of io library. --export([fwrite/2,fwrite_g/1,indentation/2,scan/2,unscan/1,build/1]). +-export([fwrite/2,fwrite/3,fwrite_g/1,indentation/2,scan/2,unscan/1, + build/1, build/2]). %% Format the arguments in Args after string Format. Just generate %% an error if there is an error in the arguments. @@ -37,22 +38,48 @@ %% and it also splits the handling of the control characters into two %% parts. --spec fwrite(Format, Data) -> FormatList when +-spec fwrite(Format, Data) -> io_lib:chars() when Format :: io:format(), - Data :: [term()], - FormatList :: [char() | io_lib:format_spec()]. + Data :: [term()]. fwrite(Format, Args) -> build(scan(Format, Args)). +-spec fwrite(Format, Data, Options) -> io_lib:chars() when + Format :: io:format(), + Data :: [term()], + Options :: [Option], + Option :: {'chars_limit', CharsLimit}, + CharsLimit :: io_lib:chars_limit(). + +fwrite(Format, Args, Options) -> + build(scan(Format, Args), Options). + %% Build the output text for a pre-parsed format list. -spec build(FormatList) -> io_lib:chars() when FormatList :: [char() | io_lib:format_spec()]. build(Cs) -> - Pc = pcount(Cs), - build(Cs, Pc, 0). + build(Cs, []). + +-spec build(FormatList, Options) -> io_lib:chars() when + FormatList :: [char() | io_lib:format_spec()], + Options :: [Option], + Option :: {'chars_limit', CharsLimit}, + CharsLimit :: io_lib:chars_limit(). + +build(Cs, Options) -> + CharsLimit = get_option(chars_limit, Options, -1), + Res1 = build_small(Cs), + {P, S, W, Other} = count_small(Res1), + case P + S + W of + 0 -> + Res1; + NumOfLimited -> + RemainingChars = sub(CharsLimit, Other), + build_limited(Res1, P, NumOfLimited, RemainingChars, 0) + end. %% Parse all control sequences in the format string. @@ -95,7 +122,7 @@ print([]) -> []. print(C, F, Ad, P, Pad, Encoding, Strings) -> - [$~] ++ print_field_width(F, Ad) ++ print_precision(P) ++ + [$~] ++ print_field_width(F, Ad) ++ print_precision(P, Pad) ++ print_pad_char(Pad) ++ print_encoding(Encoding) ++ print_strings(Strings) ++ [C]. @@ -103,8 +130,9 @@ print_field_width(none, _Ad) -> ""; print_field_width(F, left) -> integer_to_list(-F); print_field_width(F, right) -> integer_to_list(F). -print_precision(none) -> ""; -print_precision(P) -> [$. | integer_to_list(P)]. +print_precision(none, $\s) -> ""; +print_precision(none, _Pad) -> "."; % pad must be second dot +print_precision(P, _Pad) -> [$. | integer_to_list(P)]. print_pad_char($\s) -> ""; % default, no need to make explicit print_pad_char(Pad) -> [$., Pad]. @@ -126,25 +154,23 @@ collect_cseq(Fmt0, Args0) -> {F,Ad,Fmt1,Args1} = field_width(Fmt0, Args0), {P,Fmt2,Args2} = precision(Fmt1, Args1), {Pad,Fmt3,Args3} = pad_char(Fmt2, Args2), - {Encoding,Fmt4,Args4} = encoding(Fmt3, Args3), - {Strings,Fmt5,Args5} = strings(Fmt4, Args4), - {C,As,Fmt6,Args6} = collect_cc(Fmt5, Args5), - FormatSpec = #{control_char => C, args => As, width => F, adjust => Ad, - precision => P, pad_char => Pad, encoding => Encoding, - strings => Strings}, - {FormatSpec,Fmt6,Args6}. - -encoding([$t|Fmt],Args) -> - true = hd(Fmt) =/= $l, - {unicode,Fmt,Args}; -encoding(Fmt,Args) -> - {latin1,Fmt,Args}. - -strings([$l|Fmt],Args) -> - true = hd(Fmt) =/= $t, - {false,Fmt,Args}; -strings(Fmt,Args) -> - {true,Fmt,Args}. + Spec0 = #{width => F, + adjust => Ad, + precision => P, + pad_char => Pad, + encoding => latin1, + strings => true}, + {Spec1,Fmt4} = modifiers(Fmt3, Spec0), + {C,As,Fmt5,Args4} = collect_cc(Fmt4, Args3), + Spec2 = Spec1#{control_char => C, args => As}, + {Spec2,Fmt5,Args4}. + +modifiers([$t|Fmt], Spec) -> + modifiers(Fmt, Spec#{encoding => unicode}); +modifiers([$l|Fmt], Spec) -> + modifiers(Fmt, Spec#{strings => false}); +modifiers(Fmt, Spec) -> + {Spec, Fmt}. field_width([$-|Fmt0], Args0) -> {F,Fmt,Args} = field_value(Fmt0, Args0), @@ -203,40 +229,78 @@ collect_cc([$~|Fmt], Args) when is_list(Args) -> {$~,[],Fmt,Args}; collect_cc([$n|Fmt], Args) when is_list(Args) -> {$n,[],Fmt,Args}; collect_cc([$i|Fmt], [A|Args]) -> {$i,[A],Fmt,Args}. -%% pcount([ControlC]) -> Count. -%% Count the number of print requests. - -pcount(Cs) -> pcount(Cs, 0). - -pcount([#{control_char := $p}|Cs], Acc) -> pcount(Cs, Acc+1); -pcount([#{control_char := $P}|Cs], Acc) -> pcount(Cs, Acc+1); -pcount([_|Cs], Acc) -> pcount(Cs, Acc); -pcount([], Acc) -> Acc. - -%% build([Control], Pc, Indentation) -> io_lib:chars(). +%% count_small([ControlC]) -> Count. +%% Count the number of big (pPwWsS) print requests and +%% number of characters of other print (small) requests. + +count_small(Cs) -> + count_small(Cs, #{p => 0, s => 0, w => 0, other => 0}). + +count_small([#{control_char := $p}|Cs], #{p := P} = Cnts) -> + count_small(Cs, Cnts#{p := P + 1}); +count_small([#{control_char := $P}|Cs], #{p := P} = Cnts) -> + count_small(Cs, Cnts#{p := P + 1}); +count_small([#{control_char := $w}|Cs], #{w := W} = Cnts) -> + count_small(Cs, Cnts#{w := W + 1}); +count_small([#{control_char := $W}|Cs], #{w := W} = Cnts) -> + count_small(Cs, Cnts#{w := W + 1}); +count_small([#{control_char := $s}|Cs], #{w := W} = Cnts) -> + count_small(Cs, Cnts#{w := W + 1}); +count_small([S|Cs], #{other := Other} = Cnts) when is_list(S); + is_binary(S) -> + count_small(Cs, Cnts#{other := Other + string:length(S)}); +count_small([C|Cs], #{other := Other} = Cnts) when is_integer(C) -> + count_small(Cs, Cnts#{other := Other + 1}); +count_small([], #{p := P, s := S, w := W, other := Other}) -> + {P, S, W, Other}. + +%% build_small([Control]) -> io_lib:chars(). +%% Interpret the control structures, but only the small ones. +%% The big ones are saved for later. +%% build_limited([Control], NumberOfPps, NumberOfLimited, +%% CharsLimit, Indentation) %% Interpret the control structures. Count the number of print %% remaining and only calculate indentation when necessary. Must also %% be smart when calculating indentation for characters in format. -build([#{control_char := C, args := As, width := F, adjust := Ad, - precision := P, pad_char := Pad, encoding := Enc, - strings := Str} | Cs], Pc0, I) -> - S = control(C, As, F, Ad, P, Pad, Enc, Str, I), - Pc1 = decr_pc(C, Pc0), +build_small([#{control_char := C, args := As, width := F, adjust := Ad, + precision := P, pad_char := Pad, encoding := Enc}=CC | Cs]) -> + case control_small(C, As, F, Ad, P, Pad, Enc) of + not_small -> [CC | build_small(Cs)]; + S -> lists:flatten(S) ++ build_small(Cs) + end; +build_small([C|Cs]) -> [C|build_small(Cs)]; +build_small([]) -> []. + +build_limited([#{control_char := C, args := As, width := F, adjust := Ad, + precision := P, pad_char := Pad, encoding := Enc, + strings := Str} | Cs], NumOfPs0, Count0, MaxLen0, I) -> + MaxChars = if + MaxLen0 < 0 -> MaxLen0; + true -> MaxLen0 div Count0 + end, + S = control_limited(C, As, F, Ad, P, Pad, Enc, Str, MaxChars, I), + Len = string:length(S), + NumOfPs = decr_pc(C, NumOfPs0), + Count = Count0 - 1, + MaxLen = sub(MaxLen0, Len), if - Pc1 > 0 -> [S|build(Cs, Pc1, indentation(S, I))]; - true -> [S|build(Cs, Pc1, I)] + NumOfPs > 0 -> [S|build_limited(Cs, NumOfPs, Count, + MaxLen, indentation(S, I))]; + true -> [S|build_limited(Cs, NumOfPs, Count, MaxLen, I)] end; -build([$\n|Cs], Pc, _I) -> [$\n|build(Cs, Pc, 0)]; -build([$\t|Cs], Pc, I) -> [$\t|build(Cs, Pc, ((I + 8) div 8) * 8)]; -build([C|Cs], Pc, I) -> [C|build(Cs, Pc, I+1)]; -build([], _Pc, _I) -> []. +build_limited([$\n|Cs], NumOfPs, Count, MaxLen, _I) -> + [$\n|build_limited(Cs, NumOfPs, Count, MaxLen, 0)]; +build_limited([$\t|Cs], NumOfPs, Count, MaxLen, I) -> + [$\t|build_limited(Cs, NumOfPs, Count, MaxLen, ((I + 8) div 8) * 8)]; +build_limited([C|Cs], NumOfPs, Count, MaxLen, I) -> + [C|build_limited(Cs, NumOfPs, Count, MaxLen, I+1)]; +build_limited([], _, _, _, _) -> []. decr_pc($p, Pc) -> Pc - 1; decr_pc($P, Pc) -> Pc - 1; decr_pc(_, Pc) -> Pc. - %% Calculate the indentation of the end of a string given its start %% indentation. We assume tabs at 8 cols. @@ -252,64 +316,74 @@ indentation([C|Cs], I) -> indentation(Cs, indentation(C, I)); indentation([], I) -> I. -%% control(FormatChar, [Argument], FieldWidth, Adjust, Precision, PadChar, -%% Encoding, Indentation) -> String -%% 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($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($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) -> - string(atom_to_list(A), F, Adj, P, Pad); -control($s, [L0], F, Adj, P, Pad, latin1, _Str, _I) -> - L = iolist_to_chars(L0), +%% control_small(FormatChar, [Argument], FieldWidth, Adjust, Precision, +%% PadChar, Encoding) -> String +%% control_limited(FormatChar, [Argument], FieldWidth, Adjust, Precision, +%% PadChar, Encoding, StringP, ChrsLim, Indentation) -> String +%% These are the dispatch functions for the various formatting controls. + +control_small($s, [A], F, Adj, P, Pad, latin1) when is_atom(A) -> + L = iolist_to_chars(atom_to_list(A)), string(L, F, Adj, P, Pad); -control($s, [L0], F, Adj, P, Pad, unicode, _Str, _I) -> - L = cdata_to_chars(L0), - uniconv(string(L, F, Adj, P, Pad)); -control($e, [A], F, Adj, P, Pad, _Enc, _Str, _I) when is_float(A) -> +control_small($s, [A], F, Adj, P, Pad, unicode) when is_atom(A) -> + string(atom_to_list(A), F, Adj, P, Pad); +control_small($e, [A], F, Adj, P, Pad, _Enc) when is_float(A) -> fwrite_e(A, F, Adj, P, Pad); -control($f, [A], F, Adj, P, Pad, _Enc, _Str, _I) when is_float(A) -> +control_small($f, [A], F, Adj, P, Pad, _Enc) when is_float(A) -> fwrite_f(A, F, Adj, P, Pad); -control($g, [A], F, Adj, P, Pad, _Enc, _Str, _I) when is_float(A) -> +control_small($g, [A], F, Adj, P, Pad, _Enc) when is_float(A) -> fwrite_g(A, F, Adj, P, Pad); -control($b, [A], F, Adj, P, Pad, _Enc, _Str, _I) when is_integer(A) -> +control_small($b, [A], F, Adj, P, Pad, _Enc) when is_integer(A) -> unprefixed_integer(A, F, Adj, base(P), Pad, true); -control($B, [A], F, Adj, P, Pad, _Enc, _Str, _I) when is_integer(A) -> +control_small($B, [A], F, Adj, P, Pad, _Enc) when is_integer(A) -> unprefixed_integer(A, F, Adj, base(P), Pad, false); -control($x, [A,Prefix], F, Adj, P, Pad, _Enc, _Str, _I) when is_integer(A), - is_atom(Prefix) -> +control_small($x, [A,Prefix], F, Adj, P, Pad, _Enc) when is_integer(A), + is_atom(Prefix) -> prefixed_integer(A, F, Adj, base(P), Pad, atom_to_list(Prefix), true); -control($x, [A,Prefix], F, Adj, P, Pad, _Enc, _Str, _I) when is_integer(A) -> +control_small($x, [A,Prefix], F, Adj, P, Pad, _Enc) when is_integer(A) -> true = io_lib:deep_char_list(Prefix), %Check if Prefix a character list prefixed_integer(A, F, Adj, base(P), Pad, Prefix, true); -control($X, [A,Prefix], F, Adj, P, Pad, _Enc, _Str, _I) when is_integer(A), - is_atom(Prefix) -> +control_small($X, [A,Prefix], F, Adj, P, Pad, _Enc) when is_integer(A), + is_atom(Prefix) -> prefixed_integer(A, F, Adj, base(P), Pad, atom_to_list(Prefix), false); -control($X, [A,Prefix], F, Adj, P, Pad, _Enc, _Str, _I) when is_integer(A) -> +control_small($X, [A,Prefix], F, Adj, P, Pad, _Enc) when is_integer(A) -> true = io_lib:deep_char_list(Prefix), %Check if Prefix a character list prefixed_integer(A, F, Adj, base(P), Pad, Prefix, false); -control($+, [A], F, Adj, P, Pad, _Enc, _Str, _I) when is_integer(A) -> +control_small($+, [A], F, Adj, P, Pad, _Enc) when is_integer(A) -> Base = base(P), Prefix = [integer_to_list(Base), $#], prefixed_integer(A, F, Adj, Base, Pad, Prefix, true); -control($#, [A], F, Adj, P, Pad, _Enc, _Str, _I) when is_integer(A) -> +control_small($#, [A], F, Adj, P, Pad, _Enc) when is_integer(A) -> Base = base(P), Prefix = [integer_to_list(Base), $#], prefixed_integer(A, F, Adj, Base, Pad, Prefix, false); -control($c, [A], F, Adj, P, Pad, unicode, _Str, _I) when is_integer(A) -> +control_small($c, [A], F, Adj, P, Pad, unicode) when is_integer(A) -> char(A, F, Adj, P, Pad); -control($c, [A], F, Adj, P, Pad, _Enc, _Str, _I) when is_integer(A) -> +control_small($c, [A], F, Adj, P, Pad, _Enc) when is_integer(A) -> char(A band 255, F, Adj, P, Pad); -control($~, [], F, Adj, P, Pad, _Enc, _Str, _I) -> char($~, F, Adj, P, Pad); -control($n, [], F, Adj, P, Pad, _Enc, _Str, _I) -> newline(F, Adj, P, Pad); -control($i, [_A], _F, _Adj, _P, _Pad, _Enc, _Str, _I) -> []. +control_small($~, [], F, Adj, P, Pad, _Enc) -> char($~, F, Adj, P, Pad); +control_small($n, [], F, Adj, P, Pad, _Enc) -> newline(F, Adj, P, Pad); +control_small($i, [_A], _F, _Adj, _P, _Pad, _Enc) -> []; +control_small(_C, _As, _F, _Adj, _P, _Pad, _Enc) -> not_small. + +control_limited($s, [L0], F, Adj, P, Pad, latin1, _Str, CL, _I) -> + L = iolist_to_chars(L0), + string(limit_string(L, F, CL), limit_field(F, CL), Adj, P, Pad); +control_limited($s, [L0], F, Adj, P, Pad, unicode, _Str, CL, _I) -> + L = cdata_to_chars(L0), + uniconv(string(limit_string(L, F, CL), limit_field(F, CL), Adj, P, Pad)); +control_limited($w, [A], F, Adj, P, Pad, Enc, _Str, CL, _I) -> + Chars = io_lib:write(A, [{depth, -1}, {encoding, Enc}, {chars_limit, CL}]), + term(Chars, F, Adj, P, Pad); +control_limited($p, [A], F, Adj, P, Pad, Enc, Str, CL, I) -> + print(A, -1, F, Adj, P, Pad, Enc, Str, CL, I); +control_limited($W, [A,Depth], F, Adj, P, Pad, Enc, _Str, CL, _I) + when is_integer(Depth) -> + Chars = io_lib:write(A, [{depth, Depth}, {encoding, Enc}, {chars_limit, CL}]), + term(Chars, F, Adj, P, Pad); +control_limited($P, [A,Depth], F, Adj, P, Pad, Enc, Str, CL, I) + when is_integer(Depth) -> + print(A, Depth, F, Adj, P, Pad, Enc, Str, CL, I). -ifdef(UNICODE_AS_BINARIES). uniconv(C) -> @@ -332,7 +406,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,14 +417,16 @@ term(T, F, Adj, P0, Pad) -> %% print(Term, Depth, Field, Adjust, Precision, PadChar, Encoding, %% Indentation) -%% Print a term. - -print(T, D, none, Adj, P, Pad, E, Str, I) -> - print(T, D, 80, Adj, P, Pad, E, Str, I); -print(T, D, F, Adj, none, Pad, E, Str, I) -> - print(T, D, F, Adj, I+1, Pad, E, Str, I); -print(T, D, F, right, P, _Pad, Enc, Str, _I) -> - Options = [{column, P}, +%% Print a term. Field width sets maximum line length, Precision sets +%% initial indentation. + +print(T, D, none, Adj, P, Pad, E, Str, ChLim, I) -> + print(T, D, 80, Adj, P, Pad, E, Str, ChLim, I); +print(T, D, F, Adj, none, Pad, E, Str, ChLim, I) -> + print(T, D, F, Adj, I+1, Pad, E, Str, ChLim, I); +print(T, D, F, right, P, _Pad, Enc, Str, ChLim, _I) -> + Options = [{chars_limit, ChLim}, + {column, P}, {line_length, F}, {depth, D}, {encoding, Enc}, @@ -376,7 +452,7 @@ float_e(_Fl, {Ds,E}, P) -> {Fs,false} -> [Fs|float_exp(E-1)] end. -%% float_man([Digit], Icount, Dcount) -> {[Chars],CarryFlag}. +%% float_man([Digit], Icount, Dcount) -> {[Char],CarryFlag}. %% Generate the characters in the mantissa from the digits with Icount %% characters before the '.' and Dcount decimals. Handle carry and let %% caller decide what to do at top. @@ -391,7 +467,7 @@ float_man([D|Ds], I, Dc) -> {Cs,false} -> {[D|Cs],false} end; float_man([], I, Dc) -> %Pad with 0's - {string:chars($0, I, [$.|string:chars($0, Dc)]),false}. + {lists:duplicate(I, $0) ++ [$.|lists:duplicate(Dc, $0)],false}. float_man([D|_], 0) when D >= $5 -> {[],true}; float_man([_|_], 0) -> {[],false}; @@ -401,7 +477,7 @@ float_man([D|Ds], Dc) -> {Cs,true} -> {[D+1|Cs],false}; {Cs,false} -> {[D|Cs],false} end; -float_man([], Dc) -> {string:chars($0, Dc),false}. %Pad with 0's +float_man([], Dc) -> {lists:duplicate(Dc, $0),false}. %Pad with 0's %% float_exp(Exponent) -> [Char]. %% Generate the exponent of a floating point number. Always include sign. @@ -425,7 +501,7 @@ fwrite_f(Fl, F, Adj, P, Pad) when P >= 1 -> float_f(Fl, Fd, P) when Fl < 0.0 -> [$-|float_f(-Fl, Fd, P)]; float_f(Fl, {Ds,E}, P) when E =< 0 -> - float_f(Fl, {string:chars($0, -E+1, Ds),1}, P); %Prepend enough 0's + float_f(Fl, {lists:duplicate(-E+1, $0)++Ds,1}, P); %Prepend enough 0's float_f(_Fl, {Ds,E}, P) -> case float_man(Ds, E, P) of {Fs,true} -> "1" ++ Fs; %Handle carry @@ -667,15 +743,27 @@ cdata_to_chars(B) when is_binary(B) -> _ -> binary_to_list(B) end. +limit_string(S, F, CharsLimit) when CharsLimit < 0; CharsLimit >= F -> S; +limit_string(S, _F, CharsLimit) -> + case string:length(S) =< CharsLimit of + true -> S; + false -> [string:slice(S, 0, sub(CharsLimit, 3)), "..."] + end. + +limit_field(F, CharsLimit) when CharsLimit < 0; F =:= none -> + F; +limit_field(F, CharsLimit) -> + max(3, min(F, CharsLimit)). + %% string(String, Field, Adjust, Precision, PadChar) 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,20 +833,9 @@ 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 +%% A deep version of lists:duplicate/2 chars(_C, 0) -> []; @@ -791,3 +868,15 @@ lowercase([H|T]) -> [H|lowercase(T)]; lowercase([]) -> []. + +%% Make sure T does change sign. +sub(T, _) when T < 0 -> T; +sub(T, E) when T >= E -> T - E; +sub(_, _) -> 0. + +get_option(Key, TupleList, Default) -> + case lists:keyfind(Key, 1, TupleList) of + false -> Default; + {Key, Value} -> Value; + _ -> Default + end. 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..ba9d9e8434 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-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. @@ -26,6 +26,9 @@ -export([print/1,print/2,print/3,print/4,print/5,print/6]). +%% To be used by io_lib only. +-export([intermediate/6, write/1]). + %%% %%% Exported functions %%% @@ -45,20 +48,23 @@ print(Term) -> %% Used by the shell for printing records and for Unicode. -type rec_print_fun() :: fun((Tag :: atom(), NFields :: non_neg_integer()) -> - no | [FieldName :: atom()]). + 'no' | [FieldName :: atom()]). -type column() :: integer(). +-type encoding() :: epp:source_encoding() | 'unicode'. -type line_length() :: pos_integer(). -type depth() :: integer(). --type max_chars() :: integer(). +-type line_max_chars() :: integer(). +-type chars_limit() :: integer(). -type chars() :: io_lib:chars(). --type option() :: {column, column()} - | {line_length, line_length()} - | {depth, depth()} - | {max_chars, max_chars()} - | {record_print_fun, rec_print_fun()} - | {strings, boolean()} - | {encoding, latin1 | utf8 | unicode}. +-type option() :: {'chars_limit', chars_limit()} + | {'column', column()} + | {'depth', depth()} + | {'encoding', encoding()} + | {'line_length', line_length()} + | {'line_max_chars', line_max_chars()} + | {'record_print_fun', rec_print_fun()} + | {'strings', boolean()}. -type options() :: [option()]. -spec print(term(), rec_print_fun()) -> chars(); @@ -68,11 +74,12 @@ print(Term, Options) when is_list(Options) -> Col = get_option(column, Options, 1), Ll = get_option(line_length, Options, 80), D = get_option(depth, Options, -1), - M = get_option(max_chars, Options, -1), + M = get_option(line_max_chars, Options, -1), + T = get_option(chars_limit, Options, -1), RecDefFun = get_option(record_print_fun, Options, no_fun), Encoding = get_option(encoding, Options, epp:default_encoding()), Strings = get_option(strings, Options, true), - print(Term, Col, Ll, D, M, RecDefFun, Encoding, Strings); + print(Term, Col, Ll, D, M, T, RecDefFun, Encoding, Strings); print(Term, RecDefFun) -> print(Term, -1, RecDefFun). @@ -84,75 +91,102 @@ print(Term, Depth, RecDefFun) -> -spec print(term(), column(), line_length(), depth()) -> chars(). print(Term, Col, Ll, D) -> - print(Term, Col, Ll, D, _M=-1, no_fun, latin1, true). + print(Term, Col, Ll, D, _M=-1, _T=-1, no_fun, latin1, true). -spec print(term(), column(), line_length(), depth(), rec_print_fun()) -> chars(). print(Term, Col, Ll, D, RecDefFun) -> print(Term, Col, Ll, D, _M=-1, RecDefFun). --spec print(term(), column(), line_length(), depth(), max_chars(), +-spec print(term(), column(), line_length(), depth(), line_max_chars(), rec_print_fun()) -> chars(). print(Term, Col, Ll, D, M, RecDefFun) -> - print(Term, Col, Ll, D, M, RecDefFun, latin1, true). - -print(_, _, _, 0, _M, _RF, _Enc, _Str) -> "..."; -print(Term, Col, Ll, D, M, RecDefFun, Enc, Str) when Col =< 0 -> - print(Term, 1, Ll, D, M, RecDefFun, Enc, Str); -print(Term, Col, Ll, D, M0, RecDefFun, Enc, Str) when is_tuple(Term); - is_list(Term); - is_map(Term); - is_bitstring(Term) -> - If = {_S, Len} = print_length(Term, D, RecDefFun, Enc, Str), + print(Term, Col, Ll, D, M, _T=-1, RecDefFun, latin1, true). + +%% D = Depth, default -1 (infinite), or LINEMAX=30 when printing from shell +%% T = chars_limit, that is, maximal number of characters, default -1 +%% Used together with D to limit the output. It is possible that +%% more than T characters are returned. +%% 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, _T, _RF, _Enc, _Str) -> "..."; +print(_, _, _, _D, _M, 0, _RF, _Enc, _Str) -> "..."; +print(Term, Col, Ll, D, M, T, RecDefFun, Enc, Str) when Col =< 0 -> + %% ensure Col is at least 1 + print(Term, 1, Ll, D, M, T, RecDefFun, Enc, Str); +print(Atom, _Col, _Ll, _D, _M, _T, _RF, Enc, _Str) when is_atom(Atom) -> + write_atom(Atom, Enc); +print(Term, Col, Ll, D, M0, T, RecDefFun, Enc, Str) when is_tuple(Term); + is_list(Term); + is_map(Term); + is_bitstring(Term) -> + %% preprocess and compute total number of chars + {_, Len, _Dots, _} = If = + case T < 0 of + true -> print_length(Term, D, T, RecDefFun, Enc, Str); + false -> intermediate(Term, D, T, RecDefFun, Enc, Str) + end, + %% use Len as CHAR_MAX if M0 = -1 M = max_cs(M0, Len), if + Ll =:= 0 -> + write(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) -> +print(Term, _Col, _Ll, _D, _M, _T, _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) +pp({_S,Len,_,_} = If, Col, Ll, M, _TInd, _Ind, LD, W) when Len < Ll - Col - LD, Len + W + LD =< M -> write(If); -pp({{list,L}, _Len}, Col, Ll, M, TInd, Ind, LD, W) -> +pp({{list,L}, _Len, _, _}, Col, Ll, M, TInd, Ind, LD, W) -> [$[, pp_list(L, Col + 1, Ll, M, TInd, indent(1, Ind), LD, $|, W + 1), $]]; -pp({{tuple,true,L}, _Len}, Col, Ll, M, TInd, Ind, LD, W) -> +pp({{tuple,true,L}, _Len, _, _}, Col, Ll, M, TInd, Ind, LD, W) -> [${, pp_tag_tuple(L, Col, Ll, M, TInd, Ind, LD, W + 1), $}]; -pp({{tuple,false,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({{record,[{Name,NLen} | L]}, _Len}, Col, Ll, M, TInd, Ind, LD, W) -> +pp({{map,Pairs}, _Len, _, _}, 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) -> +pp({{bin,S}, _Len, _, _}, Col, Ll, M, _TInd, Ind, LD, W) -> pp_binary(S, Col + 2, Ll, M, indent(2, Ind), LD, W); -pp({S, _Len}, _Col, _Ll, _M, _TInd, _Ind, _LD, _W) -> +pp({S,_Len,_,_}, _Col, _Ll, _M, _TInd, _Ind, _LD, _W) -> S. %% 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) -> +pp_tag_tuple([{Tag,Tlen,_,_} | L], Col, Ll, M, TInd, Ind, LD, W) -> + %% this uses TInd TagInd = Tlen + 2, Tcol = Col + TagInd, S = $,, @@ -166,9 +200,49 @@ 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) -> + ""; % cannot happen +pp_map({dots, _, _, _}, _Col, _Ll, _M, _TInd, _Ind, _LD, _W) -> + "..."; % cannot happen +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) -> +pp_record({dots, _, _, _}, _Nlen, _Col, _Ll, _M, _TInd, _Ind, _LD, _W) -> "..."; pp_record([F | Fs], Nlen, Col0, Ll, M, TInd, Ind0, LD, W0) -> Nind = Nlen + 1, @@ -178,9 +252,9 @@ pp_record([F | Fs], Nlen, Col0, Ll, M, TInd, Ind0, LD, W0) -> pp_fields_tail([], _Col0, _Col, _Ll, _M, _TInd, _Ind, _LD, _W) -> ""; -pp_fields_tail({dots, _}, _Col0, _Col, _M, _Ll, _TInd, _Ind, _LD, _W) -> +pp_fields_tail({dots, _, _ ,_}, _Col0, _Col, _M, _Ll, _TInd, _Ind, _LD, _W) -> ",..."; -pp_fields_tail([{_, Len}=F | Fs], Col0, Col, Ll, M, TInd, Ind, LD, W) -> +pp_fields_tail([{_, Len, _, _}=F | Fs], Col0, Col, Ll, M, TInd, Ind, LD, W) -> LD1 = last_depth(Fs, LD), ELen = 1 + Len, if @@ -194,7 +268,7 @@ pp_fields_tail([{_, Len}=F | Fs], Col0, Col, Ll, M, TInd, Ind, LD, W) -> pp_fields_tail(Fs, Col0, Col0 + FW, Ll, M, TInd, Ind, LD, FW)] end. -pp_field({_, Len}=Fl, Col, Ll, M, _TInd, _Ind, LD, W) +pp_field({_, Len, _, _}=Fl, Col, Ll, M, _TInd, _Ind, LD, W) when Len < Ll - Col - LD, Len + W + LD =< M -> {write_field(Fl), if ?ATM_FLD(Fl) -> @@ -202,11 +276,16 @@ pp_field({_, Len}=Fl, Col, Ll, M, _TInd, _Ind, LD, W) true -> Ll % force nl end}; -pp_field({{field, Name, NameL, F}, _Len}, Col0, Ll, M, TInd, Ind0, LD, W0) -> +pp_field({{field, Name, NameL, F},_,_, _}, 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; @@ -224,15 +303,15 @@ rec_indent(RInd, TInd, Col0, Ind0, W0) -> end, {Col, Ind, S, W}. -pp_list({dots, _}, _Col0, _Ll, _M, _TInd, _Ind, _LD, _S, _W) -> +pp_list({dots, _, _, _}, _Col0, _Ll, _M, _TInd, _Ind, _LD, _S, _W) -> "..."; pp_list([E | Es], Col0, Ll, M, TInd, Ind, LD, S, W) -> {ES, WE} = pp_element(E, Col0, Ll, M, TInd, Ind, last_depth(Es, LD), W), [ES | pp_tail(Es, Col0, Col0 + WE, Ll, M, TInd, Ind, LD, S, W + WE)]. pp_tail([], _Col0, _Col, _Ll, _M, _TInd, _Ind, _LD, _S, _W) -> - ""; -pp_tail([{_, Len}=E | Es], Col0, Col, Ll, M, TInd, Ind, LD, S, W) -> + []; +pp_tail([{_, Len, _, _}=E | Es], Col0, Col, Ll, M, TInd, Ind, LD, S, W) -> LD1 = last_depth(Es, LD), ELen = 1 + Len, if @@ -245,9 +324,9 @@ pp_tail([{_, Len}=E | Es], Col0, Col, Ll, M, TInd, Ind, LD, S, W) -> [$,, $\n, Ind, ES | pp_tail(Es, Col0, Col0 + WE, Ll, M, TInd, Ind, LD, S, WE)] end; -pp_tail({dots, _}, _Col0, _Col, _Ll, _M, _TInd, _Ind, _LD, S, _W) -> +pp_tail({dots, _, _, _}, _Col0, _Col, _Ll, _M, _TInd, _Ind, _LD, S, _W) -> [S | "..."]; -pp_tail({_, Len}=E, _Col0, Col, Ll, M, _TInd, _Ind, LD, S, W) +pp_tail({_, Len, _, _}=E, _Col0, Col, Ll, M, _TInd, _Ind, LD, S, W) when Len + 1 < Ll - Col - (LD + 1), Len + 1 + W + (LD + 1) =< M, ?ATM(E) -> @@ -255,7 +334,7 @@ pp_tail({_, Len}=E, _Col0, Col, Ll, M, _TInd, _Ind, LD, S, W) pp_tail(E, Col0, _Col, Ll, M, TInd, Ind, LD, S, _W) -> [S, $\n, Ind | pp(E, Col0, Ll, M, TInd, Ind, LD + 1, 0)]. -pp_element({_, Len}=E, Col, Ll, M, _TInd, _Ind, LD, W) +pp_element({_, Len, _, _}=E, Col, Ll, M, _TInd, _Ind, LD, W) when Len < Ll - Col - LD, Len + W + LD =< M, ?ATM(E) -> {write(E), Len}; pp_element(E, Col, Ll, M, TInd, Ind, LD, W) -> @@ -285,39 +364,43 @@ pp_binary(S, N, _N0, Ind) -> S end. -write({{tuple, _IsTagged, L}, _}) -> +%% write the whole thing on a single line +write({{tuple, _IsTagged, L}, _, _, _}) -> [${, write_list(L, $,), $}]; -write({{list, L}, _}) -> +write({{list, L}, _, _, _}) -> [$[, write_list(L, $|), $]]; -write({{map, Pairs}, _}) -> +write({{map, Pairs}, _, _, _}) -> [$#,${, write_list(Pairs, $,), $}]; -write({{map_pair, K, V}, _}) -> - [write(K)," => ",write(V)]; -write({{record, [{Name,_} | L]}, _}) -> +write({{map_pair, _K, _V}, _, _, _}=Pair) -> + write_pair(Pair); +write({{record, [{Name,_} | L]}, _, _, _}) -> [Name, ${, write_fields(L), $}]; -write({{bin, S}, _}) -> +write({{bin, S}, _, _, _}) -> S; -write({S, _}) -> +write({S, _, _, _}) -> S. +write_pair({{map_pair, K, V}, _, _, _}) -> + [write(K), " => ", write(V)]. + write_fields([]) -> ""; -write_fields({dots, _}) -> +write_fields({dots, _, _, _}) -> "..."; write_fields([F | Fs]) -> [write_field(F) | write_fields_tail(Fs)]. write_fields_tail([]) -> ""; -write_fields_tail({dots, _}) -> +write_fields_tail({dots, _, _, _}) -> ",..."; write_fields_tail([F | Fs]) -> [$,, write_field(F) | write_fields_tail(Fs)]. -write_field({{field, Name, _NameL, F}, _}) -> +write_field({{field, Name, _NameL, F}, _, _, _}) -> [Name, " = " | write(F)]. -write_list({dots, _}, _S) -> +write_list({dots, _, _, _}, _S) -> "..."; write_list([E | Es], S) -> [write(E) | write_tail(Es, S)]. @@ -326,174 +409,365 @@ write_tail([], _S) -> []; write_tail([E | Es], S) -> [$,, write(E) | write_tail(Es, S)]; -write_tail({dots, _}, S) -> +write_tail({dots, _, _, _}, S) -> [S | "..."]; write_tail(E, S) -> [S | write(E)]. +-type more() :: fun((chars_limit(), DeltaDepth :: non_neg_integer()) -> + intermediate_format()). + +-type if_list() :: maybe_improper_list(intermediate_format(), + {'dots', non_neg_integer(), + non_neg_integer(), more()}). + +-type intermediate_format() :: + {chars() + | {'bin', chars()} + | 'dots' + | {'field', Name :: chars(), NameLen :: non_neg_integer(), + intermediate_format()} + | {'list', if_list()} + | {'map', if_list()} + | {'map_pair', K :: intermediate_format(), + V :: intermediate_format()} + | {'record', [{Name :: chars(), NameLen :: non_neg_integer()} + | if_list()]} + | {'tuple', IsTagged :: boolean(), if_list()}, + Len :: non_neg_integer(), + NumOfDots :: non_neg_integer(), + More :: more() | 'no_more' + }. + +-spec intermediate(term(), depth(), pos_integer(), rec_print_fun(), + encoding(), boolean()) -> intermediate_format(). + +intermediate(Term, D, T, RF, Enc, Str) when T > 0 -> + D0 = 1, + If = print_length(Term, D0, T, RF, Enc, Str), + case If of + {_, Len, Dots, _} when Dots =:= 0; Len > T; D =:= 1 -> + If; + _ -> + find_upper(If, Term, T, D0, 2, D, RF, Enc, Str) + end. + +find_upper(Lower, Term, T, Dl, Dd, D, RF, Enc, Str) -> + Dd2 = Dd * 2, + D1 = case D < 0 of + true -> Dl + Dd2; + false -> min(Dl + Dd2, D) + end, + If = expand(Lower, T, D1 - Dl), + case If of + {_, _, _Dots=0, _} -> % even if Len > T + If; + {_, Len, _, _} when Len =< T, D1 < D orelse D < 0 -> + find_upper(If, Term, T, D1, Dd2, D, RF, Enc, Str); + _ -> + search_depth(Lower, If, Term, T, Dl, D1, RF, Enc, Str) + end. + +%% Lower has NumOfDots > 0 and Len =< T. +%% Upper has NumOfDots > 0 and Len > T. +search_depth(Lower, Upper, _Term, T, Dl, Du, _RF, _Enc, _Str) + when Du - Dl =:= 1 -> + %% The returned intermediate format has Len >= T. + case Lower of + {_, T, _, _} -> + Lower; + _ -> + Upper + end; +search_depth(Lower, Upper, Term, T, Dl, Du, RF, Enc, Str) -> + D1 = (Dl + Du) div 2, + If = expand(Lower, T, D1 - Dl), + case If of + {_, Len, _, _} when Len > T -> + %% Len can be greater than Upper's length. + %% This is a bit expensive since the work to + %% crate Upper is wasted. It is the price + %% to pay to get a more balanced output. + search_depth(Lower, If, Term, T, Dl, D1, RF, Enc, Str); + _ -> + search_depth(If, Upper, Term, T, D1, Du, RF, Enc, Str) + end. + %% 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 -print_length([], _D, _RF, _Enc, _Str) -> - {"[]", 2}; -print_length({}, _D, _RF, _Enc, _Str) -> - {"{}", 2}; -print_length(#{}=M, _D, _RF, _Enc, _Str) when map_size(M) =:= 0 -> - {"#{}", 3}; -print_length(List, D, RF, Enc, Str) when is_list(List) -> - case Str andalso printable_list(List, D, Enc) of +print_length([], _D, _T, _RF, _Enc, _Str) -> + {"[]", 2, 0, no_more}; +print_length({}, _D, _T, _RF, _Enc, _Str) -> + {"{}", 2, 0, no_more}; +print_length(#{}=M, _D, _T, _RF, _Enc, _Str) when map_size(M) =:= 0 -> + {"#{}", 3, 0, no_more}; +print_length(Atom, _D, _T, _RF, Enc, _Str) when is_atom(Atom) -> + S = write_atom(Atom, Enc), + {S, string:length(S), 0, no_more}; +print_length(List, D, T, RF, Enc, Str) when is_list(List) -> + %% only flat lists are "printable" + case Str andalso printable_list(List, D, T, 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. - % {true, Prefix} -> - % S = write_string(Prefix, Enc), - % {[S | "..."], 3 + length(S)}; + {S, string:length(S), 0, no_more}; + {true, Prefix} -> + %% Truncated lists when T < 0 could break some existing code. + S = write_string(Prefix, Enc), + %% NumOfDots = 0 to avoid looping--increasing the depth + %% does not make Prefix longer. + {[S | "..."], 3 + string:length(S), 0, no_more}; false -> - print_length_list(List, D, RF, Enc, Str) + case print_length_list(List, D, T, RF, Enc, Str) of + {What, Len, Dots, _More} when Dots > 0 -> + More = fun(T1, Dd) -> + ?FUNCTION_NAME(List, D+Dd, T1, RF, Enc, Str) + end, + {What, Len, Dots, More}; + If -> + If + end end; -print_length(Fun, _D, _RF, _Enc, _Str) when is_function(Fun) -> +print_length(Fun, _D, _T, _RF, _Enc, _Str) when is_function(Fun) -> S = io_lib:write(Fun), - {S, iolist_size(S)}; -print_length(R, D, RF, Enc, Str) when is_atom(element(1, R)), - is_function(RF) -> + {S, iolist_size(S), 0, no_more}; +print_length(R, D, T, RF, Enc, Str) when is_atom(element(1, R)), + is_function(RF) -> case RF(element(1, R), tuple_size(R) - 1) of no -> - print_length_tuple(R, D, RF, Enc, Str); + print_length_tuple(R, D, T, RF, Enc, Str); RDefs -> - print_length_record(R, D, RF, RDefs, Enc, Str) + print_length_record(R, D, T, RF, RDefs, Enc, Str) end; -print_length(Tuple, D, RF, Enc, Str) when is_tuple(Tuple) -> - print_length_tuple(Tuple, D, RF, Enc, Str); -print_length(Map, D, RF, Enc, Str) when is_map(Map) -> - print_length_map(Map, D, RF, Enc, Str); -print_length(<<>>, _D, _RF, _Enc, _Str) -> - {"<<>>", 4}; -print_length(<<_/bitstring>>, 1, _RF, _Enc, _Str) -> - {"<<...>>", 7}; -print_length(<<_/bitstring>>=Bin, D, _RF, Enc, Str) -> - case bit_size(Bin) rem 8 of - 0 -> - D1 = D - 1, - case Str andalso printable_bin(Bin, D1, Enc) of - {true, List} when is_list(List) -> - S = io_lib:write_string(List, $"), %" - {[$<,$<,S,$>,$>], 4 + length(S)}; - {false, List} when is_list(List) -> - S = io_lib:write_string(List, $"), %" - {[$<,$<,S,"/utf8>>"], 9 + length(S)}; - {true, true, Prefix} -> - S = io_lib:write_string(Prefix, $"), %" - {[$<,$<, S | "...>>"], 7 + length(S)}; - {false, true, Prefix} -> - S = io_lib:write_string(Prefix, $"), %" - {[$<,$<, S | "/utf8...>>"], 12 + length(S)}; - false -> - S = io_lib:write(Bin, D), - {{bin,S}, iolist_size(S)} - end; - _ -> - S = io_lib:write(Bin, D), - {{bin,S}, iolist_size(S)} +print_length(Tuple, D, T, RF, Enc, Str) when is_tuple(Tuple) -> + print_length_tuple(Tuple, D, T, RF, Enc, Str); +print_length(Map, D, T, RF, Enc, Str) when is_map(Map) -> + print_length_map(Map, D, T, RF, Enc, Str); +print_length(<<>>, _D, _T, _RF, _Enc, _Str) -> + {"<<>>", 4, 0, no_more}; +print_length(<<_/bitstring>> = Bin, 1, _T, RF, Enc, Str) -> + More = fun(T1, Dd) -> ?FUNCTION_NAME(Bin, 1+Dd, T1, RF, Enc, Str) end, + {"<<...>>", 7, 3, More}; +print_length(<<_/bitstring>> = Bin, D, T, RF, Enc, Str) -> + D1 = D - 1, + case + Str andalso + (bit_size(Bin) rem 8) =:= 0 andalso + printable_bin0(Bin, D1, tsub(T, 6), Enc) + of + {true, List} when is_list(List) -> + S = io_lib:write_string(List, $"), %" + {[$<,$<,S,$>,$>], 4 + length(S), 0, no_more}; + {false, List} when is_list(List) -> + S = io_lib:write_string(List, $"), %" + {[$<,$<,S,"/utf8>>"], 9 + string:length(S), 0, no_more}; + {true, true, Prefix} -> + S = io_lib:write_string(Prefix, $"), %" + More = fun(T1, Dd) -> + ?FUNCTION_NAME(Bin, D+Dd, T1, RF, Enc, Str) + end, + {[$<,$<,S|"...>>"], 7 + length(S), 3, More}; + {false, true, Prefix} -> + S = io_lib:write_string(Prefix, $"), %" + More = fun(T1, Dd) -> + ?FUNCTION_NAME(Bin, D+Dd, T1, RF, Enc, Str) + end, + {[$<,$<,S|"/utf8...>>"], 12 + string:length(S), 3, More}; + false -> + case io_lib:write_binary(Bin, D, T) of + {S, <<>>} -> + {{bin, S}, iolist_size(S), 0, no_more}; + {S, _Rest} -> + More = fun(T1, Dd) -> + ?FUNCTION_NAME(Bin, D+Dd, T1, RF, Enc, Str) + end, + {{bin, S}, iolist_size(S), 3, More} + end end; -print_length(Term, _D, _RF, _Enc, _Str) -> +print_length(Term, _D, _T, _RF, _Enc, _Str) -> S = io_lib:write(Term), - {S, lists:flatlength(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), - {{map, Pairs}, list_length(Pairs, 3)}. - -print_length_map_pairs([], _D, _RF, _Enc, _Str) -> + %% S can contain unicode, so iolist_size(S) cannot be used here + {S, string:length(S), 0, no_more}. + +print_length_map(Map, 1, _T, RF, Enc, Str) -> + More = fun(T1, Dd) -> ?FUNCTION_NAME(Map, 1+Dd, T1, RF, Enc, Str) end, + {"#{...}", 6, 3, More}; +print_length_map(Map, D, T, RF, Enc, Str) when is_map(Map) -> + Next = maps:next(maps:iterator(Map)), + PairsS = print_length_map_pairs(Next, D, D - 1, tsub(T, 3), RF, Enc, Str), + {Len, Dots} = list_length(PairsS, 3, 0), + {{map, PairsS}, Len, Dots, no_more}. + +print_length_map_pairs(none, _D, _D0, _T, _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_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}. - -print_length_tuple(_Tuple, 1, _RF, _Enc, _Str) -> - {"{...}", 5}; -print_length_tuple(Tuple, D, RF, Enc, Str) -> - L = print_length_list1(tuple_to_list(Tuple), D, RF, Enc, Str), +print_length_map_pairs(Term, D, D0, T, RF, Enc, Str) when D =:= 1; T =:= 0-> + More = fun(T1, Dd) -> + ?FUNCTION_NAME(Term, D+Dd, D0, T1, RF, Enc, Str) + end, + {dots, 3, 3, More}; +print_length_map_pairs({K, V, Iter}, D, D0, T, RF, Enc, Str) -> + Pair1 = print_length_map_pair(K, V, D0, tsub(T, 1), RF, Enc, Str), + {_, Len1, _, _} = Pair1, + Next = maps:next(Iter), + [Pair1 | + print_length_map_pairs(Next, D - 1, D0, tsub(T, Len1+1), RF, Enc, Str)]. + +print_length_map_pair(K, V, D, T, RF, Enc, Str) -> + {_, KL, KD, _} = P1 = print_length(K, D, T, RF, Enc, Str), + KL1 = KL + 4, + {_, VL, VD, _} = P2 = print_length(V, D, tsub(T, KL1), RF, Enc, Str), + {{map_pair, P1, P2}, KL1 + VL, KD + VD, no_more}. + +print_length_tuple(Tuple, 1, _T, RF, Enc, Str) -> + More = fun(T1, Dd) -> ?FUNCTION_NAME(Tuple, 1+Dd, T1, RF, Enc, Str) end, + {"{...}", 5, 3, More}; +print_length_tuple(Tuple, D, T, RF, Enc, Str) -> + L = print_length_tuple1(Tuple, 1, D, tsub(T, 2), RF, Enc, Str), IsTagged = is_atom(element(1, Tuple)) and (tuple_size(Tuple) > 1), - {{tuple,IsTagged,L}, list_length(L, 2)}. - -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))], - NameL = length(Name), - Elements = tl(tuple_to_list(Tuple)), - L = print_length_fields(RDefs, D - 1, Elements, RF, Enc, Str), - {{record, [{Name,NameL} | L]}, list_length(L, NameL + 2)}. - -print_length_fields([], _D, [], _RF, _Enc, _Str) -> + {Len, Dots} = list_length(L, 2, 0), + {{tuple,IsTagged,L}, Len, Dots, no_more}. + +print_length_tuple1(Tuple, I, _D, _T, _RF, _Enc, _Str) + when I > tuple_size(Tuple) -> []; -print_length_fields(_, 1, _, _RF, _Enc, _Str) -> - {dots, 3}; -print_length_fields([Def | Defs], D, [E | Es], RF, Enc, Str) -> - [print_length_field(Def, D - 1, E, 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), - {S, L} = print_length(E, D, RF, Enc, Str), - NameL = length(Name) + 3, - {{field, Name, NameL, {S, L}}, NameL + L}. - -print_length_list(List, D, RF, Enc, Str) -> - L = print_length_list1(List, D, RF, Enc, Str), - {{list, L}, list_length(L, 2)}. - -print_length_list1([], _D, _RF, _Enc, _Str) -> +print_length_tuple1(Tuple, I, D, T, RF, Enc, Str) when D =:= 1; T =:= 0-> + More = fun(T1, Dd) -> ?FUNCTION_NAME(Tuple, I, D+Dd, T1, RF, Enc, Str) end, + {dots, 3, 3, More}; +print_length_tuple1(Tuple, I, D, T, RF, Enc, Str) -> + E = element(I, Tuple), + T1 = tsub(T, 1), + {_, Len1, _, _} = Elem1 = print_length(E, D - 1, T1, RF, Enc, Str), + T2 = tsub(T1, Len1), + [Elem1 | print_length_tuple1(Tuple, I + 1, D - 1, T2, RF, Enc, Str)]. + +print_length_record(Tuple, 1, _T, RF, RDefs, Enc, Str) -> + More = fun(T1, Dd) -> + ?FUNCTION_NAME(Tuple, 1+Dd, T1, RF, RDefs, Enc, Str) + end, + {"{...}", 5, 3, More}; +print_length_record(Tuple, D, T, RF, RDefs, Enc, Str) -> + Name = [$# | write_atom(element(1, Tuple), Enc)], + NameL = string:length(Name), + T1 = tsub(T, NameL+2), + L = print_length_fields(RDefs, D - 1, T1, Tuple, 2, RF, Enc, Str), + {Len, Dots} = list_length(L, NameL + 2, 0), + {{record, [{Name,NameL} | L]}, Len, Dots, no_more}. + +print_length_fields([], _D, _T, Tuple, I, _RF, _Enc, _Str) + when I > tuple_size(Tuple) -> + []; +print_length_fields(Term, D, T, Tuple, I, RF, Enc, Str) + when D =:= 1; T =:= 0 -> + More = fun(T1, Dd) -> + ?FUNCTION_NAME(Term, D+Dd, T1, Tuple, I, RF, Enc, Str) + end, + {dots, 3, 3, More}; +print_length_fields([Def | Defs], D, T, Tuple, I, RF, Enc, Str) -> + E = element(I, Tuple), + T1 = tsub(T, 1), + Field1 = print_length_field(Def, D - 1, T1, E, RF, Enc, Str), + {_, Len1, _, _} = Field1, + T2 = tsub(T1, Len1), + [Field1 | + print_length_fields(Defs, D - 1, T2, Tuple, I + 1, RF, Enc, Str)]. + +print_length_field(Def, D, T, E, RF, Enc, Str) -> + Name = write_atom(Def, Enc), + NameL = string:length(Name) + 3, + {_, Len, Dots, _} = + Field = print_length(E, D, tsub(T, NameL), RF, Enc, Str), + {{field, Name, NameL, Field}, NameL + Len, Dots, no_more}. + +print_length_list(List, D, T, RF, Enc, Str) -> + L = print_length_list1(List, D, tsub(T, 2), RF, Enc, Str), + {Len, Dots} = list_length(L, 2, 0), + {{list, L}, Len, Dots, no_more}. + +print_length_list1([], _D, _T, _RF, _Enc, _Str) -> []; -print_length_list1(_, 1, _RF, _Enc, _Str) -> - {dots, 3}; -print_length_list1([E | Es], D, RF, Enc, Str) -> - [print_length(E, D - 1, RF, Enc, Str) | - print_length_list1(Es, D - 1, RF, Enc, Str)]; -print_length_list1(E, D, RF, Enc, Str) -> - print_length(E, D - 1, RF, Enc, Str). - -list_length([], Acc) -> - Acc; -list_length([{_, Len} | Es], Acc) -> - list_length_tail(Es, Acc + Len); -list_length({_, Len}, Acc) -> - Acc + Len. - -list_length_tail([], Acc) -> - Acc; -list_length_tail([{_,Len} | Es], Acc) -> - list_length_tail(Es, Acc + 1 + Len); -list_length_tail({_, Len}, Acc) -> - Acc + 1 + Len. +print_length_list1(Term, D, T, RF, Enc, Str) when D =:= 1; T =:= 0-> + More = fun(T1, Dd) -> ?FUNCTION_NAME(Term, D+Dd, T1, RF, Enc, Str) end, + {dots, 3, 3, More}; +print_length_list1([E | Es], D, T, RF, Enc, Str) -> + {_, Len1, _, _} = Elem1 = print_length(E, D - 1, tsub(T, 1), RF, Enc, Str), + [Elem1 | print_length_list1(Es, D - 1, tsub(T, Len1 + 1), RF, Enc, Str)]; +print_length_list1(E, D, T, RF, Enc, Str) -> + print_length(E, D - 1, T, RF, Enc, Str). + +list_length([], Acc, DotsAcc) -> + {Acc, DotsAcc}; +list_length([{_, Len, Dots, _} | Es], Acc, DotsAcc) -> + list_length_tail(Es, Acc + Len, DotsAcc + Dots); +list_length({_, Len, Dots, _}, Acc, DotsAcc) -> + {Acc + Len, DotsAcc + Dots}. + +list_length_tail([], Acc, DotsAcc) -> + {Acc, DotsAcc}; +list_length_tail([{_, Len, Dots, _} | Es], Acc, DotsAcc) -> + list_length_tail(Es, Acc + 1 + Len, DotsAcc + Dots); +list_length_tail({_, Len, Dots, _}, Acc, DotsAcc) -> + {Acc + 1 + Len, DotsAcc + Dots}. %% ?CHARS printable characters has depth 1. -define(CHARS, 4). -printable_list(_L, 1, _Enc) -> +%% only flat lists are "printable" +printable_list(_L, 1, _T, _Enc) -> false; -printable_list(L, _D, latin1) -> +printable_list(L, _D, T, latin1) when T < 0 -> io_lib:printable_latin1_list(L); -printable_list(L, _D, _Uni) -> +printable_list(L, _D, T, Enc) when T >= 0 -> + case slice(L, tsub(T, 2)) of + false -> + false; + {prefix, Prefix} when Enc =:= latin1 -> + io_lib:printable_latin1_list(Prefix) andalso {true, Prefix}; + {prefix, Prefix} -> + %% Probably an overestimation. + io_lib:printable_list(Prefix) andalso {true, Prefix}; + all when Enc =:= latin1 -> + io_lib:printable_latin1_list(L); + all -> + io_lib:printable_list(L) + end; +printable_list(L, _D, T, _Uni) when T < 0-> io_lib:printable_list(L). -printable_bin(Bin, D, Enc) when D >= 0, ?CHARS * D =< byte_size(Bin) -> - printable_bin(Bin, erlang:min(?CHARS * D, byte_size(Bin)), D, Enc); -printable_bin(Bin, D, Enc) -> - printable_bin(Bin, byte_size(Bin), D, Enc). +slice(L, N) -> + try string:length(L) =< N of + true -> + all; + false -> + case string:slice(L, 0, N) of + "" -> + false; + Prefix -> + {prefix, Prefix} + end + catch _:_ -> false + end. + +printable_bin0(Bin, D, T, Enc) -> + Len = case D >= 0 of + true -> + %% Use byte_size() also if Enc =/= latin1. + DChars = erlang:min(?CHARS * D, byte_size(Bin)), + case T >= 0 of + true -> + erlang:min(T, DChars); + false -> + DChars + end; + false when T < 0 -> + byte_size(Bin); + false when T >= 0 -> % cannot happen + T + end, + printable_bin(Bin, Len, D, Enc). printable_bin(Bin, Len, D, latin1) -> N = erlang:min(20, Len), @@ -595,31 +869,80 @@ 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) -> io_lib:write_string(S, $"). %" +expand({_, _, _Dots=0, no_more} = If, _T, _Dd) -> If; +%% expand({{list,L}, _Len, _, no_more}, T, Dd) -> +%% {NL, NLen, NDots} = expand_list(L, T, Dd, 2), +%% {{list,NL}, NLen, NDots, no_more}; +expand({{tuple,IsTagged,L}, _Len, _, no_more}, T, Dd) -> + {NL, NLen, NDots} = expand_list(L, T, Dd, 2), + {{tuple,IsTagged,NL}, NLen, NDots, no_more}; +expand({{map, Pairs}, _Len, _, no_more}, T, Dd) -> + {NPairs, NLen, NDots} = expand_list(Pairs, T, Dd, 3), + {{map, NPairs}, NLen, NDots, no_more}; +expand({{map_pair, K, V}, _Len, _, no_more}, T, Dd) -> + {_, KL, KD, _} = P1 = expand(K, tsub(T, 1), Dd), + KL1 = KL + 4, + {_, VL, VD, _} = P2 = expand(V, tsub(T, KL1), Dd), + {{map_pair, P1, P2}, KL1 + VL, KD + VD, no_more}; +expand({{record, [{Name,NameL} | L]}, _Len, _, no_more}, T, Dd) -> + {NL, NLen, NDots} = expand_list(L, T, Dd, NameL + 2), + {{record, [{Name,NameL} | NL]}, NLen, NDots, no_more}; +expand({{field, Name, NameL, Field}, _Len, _, no_more}, T, Dd) -> + F = {_S, L, Dots, _} = expand(Field, tsub(T, NameL), Dd), + {{field, Name, NameL, F}, NameL + L, Dots, no_more}; +expand({_, _, _, More}, T, Dd) -> + More(T, Dd). + +expand_list(Ifs, T, Dd, L0) -> + L = expand_list(Ifs, tsub(T, L0), Dd), + {Len, Dots} = list_length(L, L0, 0), + {L, Len, Dots}. + +expand_list([], _T, _Dd) -> + []; +expand_list([If | Ifs], T, Dd) -> + {_, Len1, _, _} = Elem1 = expand(If, tsub(T, 1), Dd), + [Elem1 | expand_list(Ifs, tsub(T, Len1 + 1), Dd)]; +expand_list({_, _, _, More}, T, Dd) -> + More(T, Dd). + +%% Make sure T does not change sign. +tsub(T, _) when T < 0 -> T; +tsub(T, E) when T >= E -> T - E; +tsub(_, _) -> 0. + %% Throw 'no_good' if the indentation exceeds half the line length %% unless there is room for M characters on the line. -cind({_S, Len}, Col, Ll, M, Ind, LD, W) when Len < Ll - Col - LD, - Len + W + LD =< M -> +cind({_S, Len, _, _}, Col, Ll, M, Ind, LD, W) when Len < Ll - Col - LD, + Len + W + LD =< M -> Ind; -cind({{list,L}, _Len}, Col, Ll, M, Ind, LD, W) -> +cind({{list,L}, _Len, _, _}, Col, Ll, M, Ind, LD, W) -> cind_list(L, Col + 1, Ll, M, Ind, LD, W + 1); -cind({{tuple,true,L}, _Len}, Col, Ll, M, Ind, LD, W) -> +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({{tuple,false,L}, _Len, _, _}, Col, Ll, M, Ind, LD, W) -> cind_list(L, Col + 1, Ll, M, Ind, LD, W + 1); -cind({{record,[{_Name,NLen} | L]}, _Len}, Col, Ll, M, Ind, LD, W) -> +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) -> +cind({{bin,_S}, _Len, _, _}, _Col, _Ll, _M, Ind, _LD, _W) -> Ind; -cind({_S, _Len}, _Col, _Ll, _M, Ind, _LD, _W) -> +cind({_S,_Len,_,_}, _Col, _Ll, _M, Ind, _LD, _W) -> Ind. -cind_tag_tuple([{_Tag,Tlen} | L], Col, Ll, M, Ind, LD, W) -> +cind_tag_tuple([{_Tag,Tlen,_,_} | L], Col, Ll, M, Ind, LD, W) -> TagInd = Tlen + 2, Tcol = Col + TagInd, if @@ -637,6 +960,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. % cannot happen + +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), @@ -645,7 +1010,7 @@ cind_record([F | Fs], Nlen, Col0, Ll, M, Ind, LD, W0) -> cind_record(_, _Nlen, _Col, _Ll, _M, Ind, _LD, _W) -> Ind. -cind_fields_tail([{_, Len}=F | Fs], Col0, Col, Ll, M, Ind, LD, W) -> +cind_fields_tail([{_, Len, _, _} = F | Fs], Col0, Col, Ll, M, Ind, LD, W) -> LD1 = last_depth(Fs, LD), ELen = 1 + Len, if @@ -659,7 +1024,7 @@ cind_fields_tail([{_, Len}=F | Fs], Col0, Col, Ll, M, Ind, LD, W) -> cind_fields_tail(_, _Col0, _Col, _Ll, _M, Ind, _LD, _W) -> Ind. -cind_field({{field, _N, _NL, _F}, Len}=Fl, Col, Ll, M, _Ind, LD, W) +cind_field({{field, _N, _NL, _F}, Len, _, _}=Fl, Col, Ll, M, _Ind, LD, W) when Len < Ll - Col - LD, Len + W + LD =< M -> if ?ATM_FLD(Fl) -> @@ -667,7 +1032,7 @@ cind_field({{field, _N, _NL, _F}, Len}=Fl, Col, Ll, M, _Ind, LD, W) true -> Ll end; -cind_field({{field, _Name, NameL, F}, _Len}, Col0, Ll, M, Ind, LD, W0) -> +cind_field({{field, _Name, NameL, F},_Len,_,_}, Col0, Ll, M, Ind, LD, W0) -> {Col, W} = cind_rec(NameL, Col0, Ll, M, Ind, W0 + NameL), cind(F, Col, Ll, M, Ind, LD, W), Ll. @@ -690,7 +1055,7 @@ cind_rec(RInd, Col0, Ll, M, Ind, W0) -> throw(no_good) end. -cind_list({dots, _}, _Col0, _Ll, _M, Ind, _LD, _W) -> +cind_list({dots, _, _, _}, _Col0, _Ll, _M, Ind, _LD, _W) -> Ind; cind_list([E | Es], Col0, Ll, M, Ind, LD, W) -> WE = cind_element(E, Col0, Ll, M, Ind, last_depth(Es, LD), W), @@ -698,7 +1063,7 @@ cind_list([E | Es], Col0, Ll, M, Ind, LD, W) -> cind_tail([], _Col0, _Col, _Ll, _M, Ind, _LD, _W) -> Ind; -cind_tail([{_, Len}=E | Es], Col0, Col, Ll, M, Ind, LD, W) -> +cind_tail([{_, Len, _, _} = E | Es], Col0, Col, Ll, M, Ind, LD, W) -> LD1 = last_depth(Es, LD), ELen = 1 + Len, if @@ -709,9 +1074,9 @@ cind_tail([{_, Len}=E | Es], Col0, Col, Ll, M, Ind, LD, W) -> WE = cind_element(E, Col0, Ll, M, Ind, LD1, 0), cind_tail(Es, Col0, Col0 + WE, Ll, M, Ind, LD, WE) end; -cind_tail({dots, _}, _Col0, _Col, _Ll, _M, Ind, _LD, _W) -> +cind_tail({dots, _, _, _}, _Col0, _Col, _Ll, _M, Ind, _LD, _W) -> Ind; -cind_tail({_, Len}=E, _Col0, Col, Ll, M, Ind, LD, W) +cind_tail({_, Len, _, _}=E, _Col0, Col, Ll, M, Ind, LD, W) when Len + 1 < Ll - Col - (LD + 1), Len + 1 + W + (LD + 1) =< M, ?ATM(E) -> @@ -719,7 +1084,7 @@ cind_tail({_, Len}=E, _Col0, Col, Ll, M, Ind, LD, W) cind_tail(E, _Col0, Col, Ll, M, Ind, LD, _W) -> cind(E, Col, Ll, M, Ind, LD + 1, 0). -cind_element({_, Len}=E, Col, Ll, M, _Ind, LD, W) +cind_element({_, Len, _, _}=E, Col, Ll, M, _Ind, LD, W) when Len < Ll - Col - LD, Len + W + LD =< M, ?ATM(E) -> Len; cind_element(E, Col, Ll, M, Ind, LD, W) -> @@ -736,9 +1101,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/lists.erl b/lib/stdlib/src/lists.erl index 2b4472cdf7..06c90c0280 100644 --- a/lib/stdlib/src/lists.erl +++ b/lib/stdlib/src/lists.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2016. 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,8 +38,9 @@ -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]). + mapfoldl/3,mapfoldr/3,foreach/2,takewhile/2,dropwhile/2, + search/2, splitwith/2,split/2, + join/2]). %%% BIFs -export([keyfind/3, keymember/3, keysearch/3, member/2, reverse/2]). @@ -1398,6 +1399,19 @@ dropwhile(Pred, [Hd|Tail]=Rest) -> end; dropwhile(Pred, []) when is_function(Pred, 1) -> []. +-spec search(Pred, List) -> {value, Value} | false when + Pred :: fun((T) -> boolean()), + List :: [T], + Value :: T. + +search(Pred, [Hd|Tail]) -> + case Pred(Hd) of + true -> {value, Hd}; + false -> search(Pred, Tail) + end; +search(Pred, []) when is_function(Pred, 1) -> + false. + -spec splitwith(Pred, List) -> {List1, List2} when Pred :: fun((T) -> boolean()), List :: [T], @@ -1439,6 +1453,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. %%% 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 43d10f4800..60463feec2 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-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. @@ -20,17 +20,28 @@ -module(maps). --export([get/3,filter/2,fold/3, map/2, - size/1, - without/2, with/2]). +-export([get/3, filter/2,fold/3, + map/2, size/1, + update_with/3, update_with/4, + without/2, with/2, + iterator/1, next/1]). - -%%% 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]). +-opaque iterator() :: {term(), term(), iterator()} + | none | nonempty_improper_list(integer(),map()). + +-export_type([iterator/0]). + +-dialyzer({no_improper_lists, iterator/1}). + +-define(IS_ITERATOR(I), is_tuple(I) andalso tuple_size(I) == 3; I == none; is_integer(hd(I)) andalso is_map(tl(I))). + +%% Shadowed by erl_bif_types: maps:get/2 -spec get(Key,Map) -> Value when Key :: term(), Map :: map(), @@ -38,7 +49,6 @@ get(_,_) -> erlang:nif_error(undef). - -spec find(Key,Map) -> {ok, Value} | error when Key :: term(), Map :: map(), @@ -46,7 +56,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 +66,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 +82,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 +98,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,15 +115,30 @@ 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). -spec to_list(Map) -> [{Key,Value}] when Map :: map(), Key :: term(), Value :: term(). -to_list(_) -> erlang:nif_error(undef). +to_list(Map) when is_map(Map) -> + to_list_internal(erts_internal:map_next(0, Map, [])); +to_list(Map) -> + erlang:error({badmap,Map},[Map]). +to_list_internal([Iter, Map | Acc]) when is_integer(Iter) -> + to_list_internal(erts_internal:map_next(Iter, Map, Acc)); +to_list_internal(Acc) -> + Acc. +%% Shadowed by erl_bif_types: maps:update/3 -spec update(Key,Value,Map1) -> Map2 when Key :: term(), Value :: term(), @@ -127,8 +155,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(), @@ -147,47 +207,80 @@ get(Key,Map,Default) -> erlang:error({badmap,Map},[Key,Map,Default]). --spec filter(Pred,Map1) -> Map2 when +-spec filter(Pred,MapOrIter) -> Map when Pred :: fun((Key, Value) -> boolean()), Key :: term(), Value :: term(), - Map1 :: map(), - Map2 :: map(). + MapOrIter :: map() | iterator(), + Map :: map(). filter(Pred,Map) when is_function(Pred,2), is_map(Map) -> - maps:from_list([{K,V}||{K,V}<-maps:to_list(Map),Pred(K,V)]); + maps:from_list(filter_1(Pred, iterator(Map))); +filter(Pred,Iterator) when is_function(Pred,2), ?IS_ITERATOR(Iterator) -> + maps:from_list(filter_1(Pred, Iterator)); filter(Pred,Map) -> erlang:error(error_type(Map),[Pred,Map]). - --spec fold(Fun,Init,Map) -> Acc when +filter_1(Pred, Iter) -> + case next(Iter) of + {K, V, NextIter} -> + case Pred(K,V) of + true -> + [{K,V} | filter_1(Pred, NextIter)]; + false -> + filter_1(Pred, NextIter) + end; + none -> + [] + end. + +-spec fold(Fun,Init,MapOrIter) -> Acc when Fun :: fun((K, V, AccIn) -> AccOut), Init :: term(), Acc :: term(), AccIn :: term(), AccOut :: term(), - Map :: map(), + MapOrIter :: map() | iterator(), K :: term(), V :: term(). fold(Fun,Init,Map) when is_function(Fun,3), is_map(Map) -> - lists:foldl(fun({K,V},A) -> Fun(K,V,A) end,Init,maps:to_list(Map)); + fold_1(Fun,Init,iterator(Map)); +fold(Fun,Init,Iterator) when is_function(Fun,3), ?IS_ITERATOR(Iterator) -> + fold_1(Fun,Init,Iterator); fold(Fun,Init,Map) -> - erlang:error(error_type(Map),[Fun,Init,Map]). + erlang:error(error_type_iter(Map),[Fun,Init,Map]). --spec map(Fun,Map1) -> Map2 when +fold_1(Fun, Acc, Iter) -> + case next(Iter) of + {K, V, NextIter} -> + fold_1(Fun, Fun(K,V,Acc), NextIter); + none -> + Acc + end. + +-spec map(Fun,MapOrIter) -> Map when Fun :: fun((K, V1) -> V2), - Map1 :: map(), - Map2 :: map(), + MapOrIter :: map() | iterator(), + Map :: map(), K :: term(), V1 :: term(), V2 :: term(). map(Fun,Map) when is_function(Fun, 2), is_map(Map) -> - maps:from_list([{K,Fun(K,V)}||{K,V}<-maps:to_list(Map)]); + maps:from_list(map_1(Fun, iterator(Map))); +map(Fun,Iterator) when is_function(Fun, 2), ?IS_ITERATOR(Iterator) -> + maps:from_list(map_1(Fun, Iterator)); map(Fun,Map) -> - erlang:error(error_type(Map),[Fun,Map]). + erlang:error(error_type_iter(Map),[Fun,Map]). +map_1(Fun, Iter) -> + case next(Iter) of + {K, V, NextIter} -> + [{K, Fun(K, V)} | map_1(Fun, NextIter)]; + none -> + [] + end. -spec size(Map) -> non_neg_integer() when Map :: map(). @@ -197,6 +290,26 @@ size(Map) when is_map(Map) -> size(Val) -> erlang:error({badmap,Val},[Val]). +-spec iterator(Map) -> Iterator when + Map :: map(), + Iterator :: iterator(). + +iterator(M) when is_map(M) -> [0 | M]; +iterator(M) -> erlang:error({badmap, M}, [M]). + +-spec next(Iterator) -> {Key, Value, NextIterator} | 'none' when + Iterator :: iterator(), + Key :: term(), + Value :: term(), + NextIterator :: iterator(). +next({K, V, I}) -> + {K, V, I}; +next([Path | Map]) when is_integer(Path), is_map(Map) -> + erts_internal:map_next(Path, Map, iterator); +next(none) -> + none; +next(Iter) -> + erlang:error(badarg, [Iter]). -spec without(Ks,Map1) -> Map2 when Ks :: [K], @@ -205,11 +318,10 @@ size(Val) -> K :: term(). without(Ks,M) when is_list(Ks), is_map(M) -> - lists:foldl(fun(K, M1) -> ?MODULE:remove(K, M1) end, M, Ks); + lists:foldl(fun(K, M1) -> maps:remove(K, M1) end, M, Ks); without(Ks,M) -> erlang:error(error_type(M),[Ks,M]). - -spec with(Ks, Map1) -> Map2 when Ks :: [K], Map1 :: map(), @@ -218,17 +330,20 @@ without(Ks,M) -> 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)); + case maps:find(K, Map1) of + {ok, V} -> + [{K, V} | List]; + error -> + List + end + end, + maps:from_list(lists:foldl(Fun, [], Ks)); with(Ks,M) -> erlang:error(error_type(M),[Ks,M]). error_type(M) when is_map(M) -> badarg; error_type(V) -> {badmap, V}. + +error_type_iter(M) when is_map(M); ?IS_ITERATOR(M) -> badarg; +error_type_iter(V) -> {badmap, V}. 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..6d243e1bec 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-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. @@ -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,9 +224,12 @@ transform_from_shell(Dialect, Clauses, BoundEnvironment) -> %% Called when translating during compiling %% --spec parse_transform(Forms, Options) -> Forms when - Forms :: [erl_parse:abstract_form()], - Options :: term(). +-spec parse_transform(Forms, Options) -> Forms2 | Errors | Warnings when + Forms :: [erl_parse:abstract_form() | erl_parse:form_info()], + Forms2 :: [erl_parse:abstract_form() | erl_parse:form_info()], + Options :: term(), + Errors :: {error, ErrInfo :: [tuple()], WarnInfo :: []}, + Warnings :: {warning, Forms2, WarnInfo :: [tuple()]}. parse_transform(Forms, _Options) -> SaveFilename = setup_filename(), @@ -307,15 +310,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 +453,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 +503,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 +735,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) -> @@ -913,6 +931,7 @@ bool_test(is_port,1) -> true; bool_test(is_reference,1) -> true; bool_test(is_tuple,1) -> true; bool_test(is_map,1) -> true; +bool_test(is_map_key, 2) -> true; bool_test(is_binary,1) -> true; bool_test(is_function,1) -> true; bool_test(is_record,2) -> true; @@ -927,7 +946,9 @@ real_guard_function(node,0) -> true; real_guard_function(node,1) -> true; real_guard_function(round,1) -> true; real_guard_function(size,1) -> true; +real_guard_function(bit_size,1) -> true; real_guard_function(map_size,1) -> true; +real_guard_function(map_get,2) -> true; real_guard_function(tl,1) -> true; real_guard_function(trunc,1) -> true; real_guard_function(self,0) -> true; @@ -1099,5 +1120,3 @@ normalise_list([H|T]) -> [normalise(H)|normalise_list(T)]; normalise_list([]) -> []. - - 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..176047079b 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-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. @@ -19,7 +19,7 @@ -module(ordsets). --export([new/0,is_set/1,size/1,to_list/1,from_list/1]). +-export([new/0,is_set/1,size/1,is_empty/1,to_list/1,from_list/1]). -export([is_element/2,add_element/2,del_element/2]). -export([union/2,union/1,intersection/2,intersection/1]). -export([is_disjoint/2]). @@ -60,6 +60,13 @@ is_set([], _) -> true. size(S) -> length(S). +%% is_empty(OrdSet) -> boolean(). +%% Return 'true' if OrdSet is an empty set, otherwise 'false'. +-spec is_empty(Ordset) -> boolean() when + Ordset :: ordset(_). + +is_empty(S) -> S=:=[]. + %% to_list(OrdSet) -> [Elem]. %% Return the elements in OrdSet as a list. diff --git a/lib/stdlib/src/otp_internal.erl b/lib/stdlib/src/otp_internal.erl index 9d394e19d7..aaed13ba3a 100644 --- a/lib/stdlib/src/otp_internal.erl +++ b/lib/stdlib/src/otp_internal.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1999-2016. All Rights Reserved. +%% Copyright Ericsson AB 1999-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. @@ -35,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 -> @@ -47,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\" " @@ -70,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}}; +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 add in R16B01 *** +%% *** 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 *** @@ -391,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, _, _) -> @@ -515,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? @@ -541,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) -> @@ -570,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"}; @@ -650,8 +580,50 @@ 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, _, _) -> - {deprecated, "deprecated; will be removed in OTP 19"}; + {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"}; + +obsolete_1(erlang, get_stacktrace, 0) -> + {deprecated, "deprecated; use the new try/catch syntax for retrieving the stack backtrace"}; + +%% Removed in OTP 20. + +obsolete_1(erlang, hash, 2) -> + {removed, {erlang, phash2, 2}, "20.0"}; + +%% Add in OTP 21. + +obsolete_1(ssl, ssl_accept, 1) -> + {deprecated, "deprecated; use ssl:handshake/1 instead"}; +obsolete_1(ssl, ssl_accept, 2) -> + {deprecated, "deprecated; use ssl:handshake/2 instead"}; +obsolete_1(ssl, ssl_accept, 3) -> + {deprecated, "deprecated; use ssl:handshake/3 instead"}; +obsolete_1(otp_mib, F, _) when F =:= load; F =:= unload -> + {deprecated, "deprecated; functionality will be removed in a future release"}; + +%% not obsolete obsolete_1(_, _, _) -> no. @@ -705,6 +677,7 @@ is_snmp_agent_function(_, _) -> false. -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} -> @@ -718,13 +691,10 @@ obsolete_type(Module, Name, NumberOfVariables) -> 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..599be55607 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-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. @@ -25,7 +25,7 @@ %% with the least load !!!! %% This function is callable from any node including the master %% That is part of the pool -%% nodes are scheduled on a per usgae basis and per load basis, +%% nodes are scheduled on a per usage basis and per load basis, %% Whenever we use a node, we put at the end of the queue, and whenever %% a node report a change in load, we insert it accordingly @@ -197,7 +197,7 @@ pure_insert({Load,Node},[{L,N}|Tail]) when Load < L -> pure_insert(L,[H|T]) -> [H|pure_insert(L,T)]. %% Really should not measure the contributions from -%% the back ground processes here .... which we do :-( +%% the background processes here .... which we do :-( %% We don't have to monitor the master, since we're slaves anyway statistic_collector() -> @@ -213,7 +213,7 @@ statistic_collector(I) -> stat_loop(M, 999999) end. -%% Do not tell the master about our load if it has not changed +%% Do not tell the master about our load if it has not changed stat_loop(M, Old) -> sleep(2000), diff --git a/lib/stdlib/src/proc_lib.erl b/lib/stdlib/src/proc_lib.erl index 10c476a6f5..cfbaf8b242 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-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. @@ -30,7 +30,7 @@ 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,format/3, + init_p/3,init_p/5,format/1,format/2,format/3,report_cb/2, initial_call/1, translate_initial_call/1, stop/1, stop/3]). @@ -40,15 +40,24 @@ -export_type([spawn_option/0]). +-include("logger.hrl"). + %%----------------------------------------------------------------------------- -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,8 +233,8 @@ init_p(Parent, Ancestors, Fun) when is_function(Fun) -> try Fun() catch - Class:Reason -> - exit_p(Class, Reason) + Class:Reason:Stacktrace -> + exit_p(Class, Reason, Stacktrace) end. -spec init_p(pid(), [pid()], atom(), atom(), [term()]) -> term(). @@ -239,8 +248,8 @@ init_p_do_apply(M, F, A) -> try apply(M, F, A) catch - Class:Reason -> - exit_p(Class, Reason) + Class:Reason:Stacktrace -> + exit_p(Class, Reason, Stacktrace) end. -spec wake_up(atom(), atom(), [term()]) -> term(). @@ -249,23 +258,30 @@ wake_up(M, F, A) when is_atom(M), is_atom(F), is_list(A) -> try apply(M, F, A) catch - Class:Reason -> - exit_p(Class, Reason) + Class:Reason:Stacktrace -> + exit_p(Class, Reason, 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(), @@ -472,16 +488,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)}. @@ -489,26 +501,31 @@ 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), - 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_1(Class, Reason) -> +crash_report(exit, normal, _, _) -> ok; +crash_report(exit, shutdown, _, _) -> ok; +crash_report(exit, {shutdown,_}, _, _) -> ok; +crash_report(Class, Reason, StartF, Stacktrace) -> + ?LOG_ERROR(#{label=>{proc_lib,crash}, + report=>[my_info(Class, Reason, StartF, Stacktrace), + linked_info(self())]}, + #{domain=>[otp,sasl], + report_cb=>fun proc_lib:report_cb/2, + logger_formatter=>#{title=>"CRASH REPORT"}, + error_logger=>#{tag=>error_report,type=>crash_report}}). + +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, 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), @@ -528,12 +545,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]) -> @@ -571,20 +625,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) -> @@ -689,9 +747,20 @@ check({badrpc,Error}) -> Error; check(Res) -> Res. %%% ----------------------------------------------------------- -%%% Format (and write) a generated crash info structure. +%%% Format a generated crash info structure. %%% ----------------------------------------------------------- +-spec report_cb(CrashReport,FormatOpts) -> unicode:chardata() when + CrashReport :: #{label => {proc_lib,crash}, + report => [term()]}, + FormatOpts :: logger:report_cb_config(). +report_cb(#{label:={proc_lib,crash}, report:=CrashReport}, Extra) -> + Default = #{chars_limit => unlimited, + depth => unlimited, + single_line => false, + encoding => utf8}, + do_format(CrashReport, maps:merge(Default,Extra)). + -spec format(CrashReport) -> string() when CrashReport :: [term()]. format(CrashReport) -> @@ -709,67 +778,135 @@ format(CrashReport, Encoding) -> Encoding :: latin1 | unicode | utf8, Depth :: unlimited | pos_integer(). -format([OwnReport,LinkReport], Encoding, Depth) -> - Extra = {Encoding,Depth}, - OwnFormat = format_report(OwnReport, Extra), - LinkFormat = format_report(LinkReport, Extra), - Str = io_lib:format(" crasher:~n~ts neighbours:~n~ts", - [OwnFormat, LinkFormat]), +format(CrashReport, Encoding, Depth) -> + do_format(CrashReport, #{chars_limit => unlimited, + depth => Depth, + encoding => Encoding, + single_line => false}). + +do_format([OwnReport,LinkReport], #{single_line:=Single}=Extra) -> + Indent = if Single -> ""; + true -> " " + end, + MyIndent = Indent ++ Indent, + Sep = nl(Single,"; "), + OwnFormat = format_report(OwnReport, MyIndent, Extra), + LinkFormat = lists:join(Sep,format_link_report(LinkReport, MyIndent, Extra)), + Nl = nl(Single," "), + Str = io_lib:format("~scrasher:"++Nl++"~ts"++Sep++"~sneighbours:"++Nl++"~ts", + [Indent,OwnFormat,Indent,LinkFormat]), lists:flatten(Str). -format_report(Rep, Extra) when is_list(Rep) -> - format_rep(Rep, Extra); -format_report(Rep, {Enc,_}) -> - io_lib:format("~"++modifier(Enc)++"p~n", [Rep]). - -format_rep([{initial_call,InitialCall}|Rep], {_Enc,Depth}=Extra) -> - [format_mfa(InitialCall, Depth)|format_rep(Rep, Extra)]; -format_rep([{error_info,{Class,Reason,StackTrace}}|Rep], Extra) -> - [format_exception(Class, Reason, StackTrace, Extra)|format_rep(Rep, Extra)]; -format_rep([{Tag,Data}|Rep], Extra) -> - [format_tag(Tag, Data, Extra)|format_rep(Rep, Extra)]; -format_rep(_, _Extra) -> +format_link_report([Link|Reps], Indent0, #{single_line:=Single}=Extra) -> + Rep = case Link of + {neighbour,Rep0} -> Rep0; + _ -> Link + end, + Indent = if Single -> ""; + true -> Indent0 + end, + LinkIndent = [" ",Indent], + [[Indent,"neighbour:",nl(Single," "),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, #{single_line:=Single}=Extra) when is_list(Rep) -> + lists:join(nl(Single,", "),format_rep(Rep, Indent, Extra)); +format_report(Rep, Indent0, #{encoding:=Enc,depth:=Depth, + chars_limit:=Limit,single_line:=Single}) -> + {P,Tl} = p(Enc,Depth), + {Indent,Width} = if Single -> {"","0"}; + true -> {Indent0,""} + end, + Opts = if is_integer(Limit) -> [{chars_limit,Limit}]; + true -> [] + end, + io_lib:format("~s~"++Width++P, [Indent, Rep | Tl], Opts). + +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,_}=Extra) -> +format_exception(Class, Reason, StackTrace, + #{encoding:=Enc,depth:=Depth,chars_limit:=Limit, + single_line:=Single}=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"]. + if Single -> + {P,Tl} = p(Enc,Depth), + Opts = if is_integer(Limit) -> [{chars_limit,Limit}]; + true -> [] + end, + [atom_to_list(Class), ": ", + io_lib:format("~0"++P,[{Reason,StackTrace}|Tl],Opts)]; + true -> + EI = " ", + [EI, erl_error:format_exception(1+length(EI), Class, Reason, + StackTrace, StackFun, PF, Enc)] + end. -format_mfa({M,F,Args}=StartF, Depth) -> +format_mfa(Indent0, {M,F,Args}=StartF, #{encoding:=Enc,single_line:=Single}=Extra) -> + Indent = if Single -> ""; + true -> Indent0 + end, try A = length(Args), - [" initial call: ",atom_to_list(M),$:,atom_to_list(F),$/, - integer_to_list(A),"\n"] + [Indent,"initial call: ",atom_to_list(M),$:,to_string(F, Enc),$/, + integer_to_list(A)] catch error:_ -> - format_tag(initial_call, StartF, Depth) + format_tag(Indent, initial_call, StartF, Extra) end. -pp_fun({Enc,Depth}) -> - {Letter,Tl} = case Depth of - unlimited -> {"p",[]}; - _ -> {"P",[Depth]} - end, - P = modifier(Enc) ++ Letter, +to_string(A, latin1) -> + io_lib:write_atom_as_latin1(A); +to_string(A, _) -> + io_lib:write_atom(A). + +pp_fun(#{encoding:=Enc,depth:=Depth,chars_limit:=Limit,single_line:=Single}) -> + {P,Tl} = p(Enc, Depth), + Width = if Single -> "0"; + true -> "" + end, + Opts = if is_integer(Limit) -> [{chars_limit,Limit}]; + true -> [] + end, fun(Term, I) -> - io_lib:format("~." ++ integer_to_list(I) ++ P, [Term|Tl]) + io_lib:format("~" ++ Width ++ "." ++ integer_to_list(I) ++ P, + [Term|Tl], Opts) end. -format_tag(Tag, Data, {_Enc,Depth}) -> - case Depth of - unlimited -> - io_lib:format(" ~p: ~80.18p~n", [Tag, Data]); - _ -> - io_lib:format(" ~p: ~80.18P~n", [Tag, Data, Depth]) - end. +format_tag(Indent0, Tag, Data, #{encoding:=Enc,depth:=Depth,chars_limit:=Limit,single_line:=Single}) -> + {P,Tl} = p(Enc, Depth), + {Indent,Width} = if Single -> {"","0"}; + true -> {Indent0,""} + end, + Opts = if is_integer(Limit) -> [{chars_limit,Limit}]; + true -> [] + end, + io_lib:format("~s~" ++ Width ++ "p: ~" ++ Width ++ ".18" ++ P, + [Indent, Tag, Data|Tl], Opts). + +p(Encoding, Depth) -> + {Letter, Tl} = case Depth of + unlimited -> {"p", []}; + _ -> {"P", [Depth]} + end, + P = modifier(Encoding) ++ Letter, + {P, Tl}. modifier(latin1) -> ""; modifier(_) -> "t". +nl(true,Else) -> Else; +nl(false,_) -> "\n". %%% ----------------------------------------------------------- %%% Stop a process and wait for it to terminate 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 1ae7c6cc25..a1c1117e31 100644 --- a/lib/stdlib/src/qlc.erl +++ b/lib/stdlib/src/qlc.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2004-2016. All Rights Reserved. +%% Copyright Ericsson AB 2004-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. @@ -301,11 +301,11 @@ eval(QH, Options) -> post_funs(Post) end end - catch Term -> - case erlang:get_stacktrace() of + catch throw:Term:Stacktrace -> + case Stacktrace of [?THROWN_ERROR | _] -> Term; - Stacktrace -> + _ -> erlang:raise(throw, Term, Stacktrace) end end @@ -359,11 +359,11 @@ fold(Fun, Acc0, QH, Options) -> post_funs(Post) end end - catch Term -> - case erlang:get_stacktrace() of + catch throw:Term:Stacktrace -> + case Stacktrace of [?THROWN_ERROR | _] -> Term; - Stacktrace -> + _ -> erlang:raise(throw, Term, Stacktrace) end end @@ -457,11 +457,11 @@ info(QH, Options) -> debug -> % Not documented. Intended for testing only. Info end - catch Term -> - case erlang:get_stacktrace() of + catch throw:Term:Stacktrace -> + case Stacktrace of [?THROWN_ERROR | _] -> Term; - Stacktrace -> + _ -> erlang:raise(throw, Term, Stacktrace) end end @@ -635,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 erl_eval: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, @@ -652,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; @@ -734,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). @@ -769,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 @@ -810,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}; @@ -887,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}; @@ -1042,9 +1056,9 @@ cursor_process(H, GUnique, GCache, TmpDir, SpawnOptions, MaxList, TmpUsage) -> Prep = prepare_qlc(H, not_a_list, GUnique, GCache, TmpDir, MaxList, TmpUsage), setup_qlc(Prep, Setup) - catch Class:Reason -> - Parent ! {self(), {caught, Class, Reason, - erlang:get_stacktrace()}}, + catch Class:Reason:Stacktrace -> + Parent ! {self(), + {caught, Class, Reason, Stacktrace}}, exit(normal) end, Parent ! {self(), ok}, @@ -1061,8 +1075,8 @@ parent_fun(Pid, Parent) -> {TPid, {parent_fun, Fun}} -> V = try {value, Fun()} - catch Class:Reason -> - {parent_fun_caught, Class, Reason, erlang:get_stacktrace()} + catch Class:Reason:Stacktrace -> + {parent_fun_caught, Class, Reason, Stacktrace} end, TPid ! {Parent, V}, parent_fun(Pid, Parent); @@ -1087,9 +1101,9 @@ reply(Parent, MonRef, Post, Cont) -> throw_error(Cont) end catch - Class:Reason -> + Class:Reason:Stacktrace -> post_funs(Post), - Message = {caught, Class, Reason, erlang:get_stacktrace()}, + Message = {caught, Class, Reason, Stacktrace}, Parent ! {self(), Message}, exit(normal) end, @@ -1118,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. @@ -1179,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} = + erl_eval:extended_parse_exprs(Tokens), + [Expr] = erl_eval:subst_values_for_vars(Es, Bs), + special(Expr); false -> % abstract expression TableDesc end; @@ -1209,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) -> @@ -1291,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)). @@ -1362,8 +1392,9 @@ 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()); + {current_stacktrace, CurrentStacktrace} = + erlang:process_info(self(), current_stacktrace), + erlang:raise(Class, Reason, Stacktrace ++ CurrentStacktrace); error -> erlang:error({qlc_cursor_pid_no_longer_exists, Pid}) end; @@ -2595,9 +2626,9 @@ table_handle(#qlc_table{trav_fun = TraverseFun, trav_MS = TravMS, Parent =:= self() -> try ParentFun() - catch Class:Reason -> + catch Class:Reason:Stacktrace -> post_funs(Post), - erlang:raise(Class, Reason, erlang:get_stacktrace()) + erlang:raise(Class, Reason, Stacktrace) end; true -> case monitor_request(Parent, {parent_fun, ParentFun}) of @@ -3001,9 +3032,9 @@ file_sort_handle(H, Kp, SortOptions, TmpDir, Compressed, Post, LocalPost) -> {terms, BTerms} -> try {[binary_to_term(B) || B <- BTerms], Post, LocalPost} - catch Class:Reason -> + catch Class:Reason:Stacktrace -> post_funs(Post), - erlang:raise(Class, Reason, erlang:get_stacktrace()) + erlang:raise(Class, Reason, Stacktrace) end end. @@ -3013,9 +3044,9 @@ do_sort(In, Out, Sort, SortOptions, Post) -> {error, Reason} -> throw_reason(Reason); Reply -> Reply end - catch Class:Term -> + catch Class:Term:Stacktrace -> post_funs(Post), - erlang:raise(Class, Term, erlang:get_stacktrace()) + erlang:raise(Class, Term, Stacktrace) end. do_sort(In, Out, sort, SortOptions) -> @@ -3718,7 +3749,7 @@ maybe_error_logger(Name, Why) -> expand_stacktrace(), Trimmer = fun(M, _F, _A) -> M =:= erl_eval end, Formater = fun(Term, I) -> io_lib:print(Term, I, 80, -1) end, - X = lib:format_stacktrace(1, Stacktrace, Trimmer, Formater), + X = erl_error:format_stacktrace(1, Stacktrace, Trimmer, Formater), error_logger:Name("qlc: temporary file was needed for ~w\n~ts\n", [Why, lists:flatten(X)]). @@ -3765,9 +3796,9 @@ call(undefined, _Arg, Default, _Post) -> call(Fun, Arg, _Default, Post) -> try Fun(Arg) - catch Class:Reason -> + catch Class:Reason:Stacktrace -> post_funs(Post), - erlang:raise(Class, Reason, erlang:get_stacktrace()) + erlang:raise(Class, Reason, Stacktrace) end. grd(undefined, _Arg) -> diff --git a/lib/stdlib/src/qlc_pt.erl b/lib/stdlib/src/qlc_pt.erl index 9577d17a85..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 @@ -434,7 +439,7 @@ compile_forms(Forms0, Options) -> (_) -> false end, Forms = ([F || F <- Forms0, not Exclude(element(1, F))] - ++ [{eof,anno0()}]), + ++ [{eof,0}]), try case compile:noenv_forms(Forms, compile_options(Options)) of {ok, _ModName, Ws0} -> @@ -1517,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). @@ -1650,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}). @@ -1868,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}. @@ -1878,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, @@ -1885,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}; @@ -1914,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. @@ -2482,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}]}, @@ -2609,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), @@ -2633,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 @@ -2872,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 d455abf7b0..362e98006e 100644 --- a/lib/stdlib/src/rand.erl +++ b/lib/stdlib/src/rand.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2015-2016. 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, statistical distribution +%% improvements and uniform_real added by the Erlang/OTP team 2017 %% ===================================================================== -module(rand). @@ -27,34 +30,191 @@ -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 + uniform_real/0, uniform_real_s/1, + jump/0, jump/1, + normal/0, normal/2, normal_s/1, normal_s/3 ]). +%% Debug +-export([make_float/3, float2str/1, bc64/1]). + -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( + BC(V, N), + bc((V), ?BIT((N) - 1), 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 55 bits is required for the floating point +%% producing fallbacks, but 56 bits would be more future proof. +%% +%% The fields 'next', 'uniform' and 'uniform_n' +%% implement the algorithm. If 'uniform' or 'uniform_n' +%% is not present there is a fallback using 'next' and either +%% 'bits' or the deprecated 'max'. The 'next' function +%% must generate a word with at least 56 good random bits. +%% +%% The 'weak_low_bits' field indicate how many bits are of +%% lesser quality and they will not be used by the floating point +%% producing functions, nor by the range producing functions +%% when more bits are needed, to avoid weak bits in the middle +%% of the generated bits. The lowest bits from the range +%% functions still have the generator's quality. +%% +-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 = maps:get(weak_low_bits, Alg, 0), + %% 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 @@ -68,7 +228,7 @@ export_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 +237,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 +276,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 +289,259 @@ 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 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 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. + +%% uniform_real/0: returns a random float X where 0.0 < X =< 1.0, +%% updating the state in the process dictionary. + +-spec uniform_real() -> X :: float(). +uniform_real() -> + {X, Seed} = uniform_real_s(seed_get()), + _ = seed_put(Seed), + X. + +%% uniform_real_s/1: given a state, uniform_s/1 +%% returns a random float X where 0.0 < X =< 1.0, +%% and a new state. +%% +%% This function does not use the same form of uniformity +%% as the uniform_s/1 function. +%% +%% Instead, this function does not generate numbers with equal +%% distance in the interval, but rather tries to keep all mantissa +%% bits random also for small numbers, meaning that the distance +%% between possible numbers decreases when the numbers +%% approaches 0.0, as does the possibility for a particular +%% number. Hence uniformity is preserved. +%% +%% To generate 56 bits at the time instead of 53 is actually +%% a speed optimization since the probability to have to +%% generate a second word decreases by 1/2 for every extra bit. +%% +%% This function generates normalized numbers, so the smallest number +%% that can be generated is 2^-1022 with the distance 2^-1074 +%% to the next to smallest number, compared to 2^-53 for uniform_s/1. +%% +%% This concept of uniformity should work better for applications +%% where you need to calculate 1.0/X or math:log(X) since those +%% operations benefits from larger precision approaching 0.0, +%% and that this function does not return 0.0 nor denormalized +%% numbers very close to 0.0. The log() operation in The Box-Muller +%% transformation for normal distribution is an example of this. +%% +%%-define(TWO_POW_MINUS55, (math:pow(2, -55))). +%%-define(TWO_POW_MINUS110, (math:pow(2, -110))). +%%-define(TWO_POW_MINUS55, 2.7755575615628914e-17). +%%-define(TWO_POW_MINUS110, 7.7037197775489436e-34). +%% +-spec uniform_real_s(State :: state()) -> {X :: float(), NewState :: state()}. +uniform_real_s({#{bits:=Bits, next:=Next} = Alg, R0}) -> + %% Generate a 56 bit number without using the weak low bits. + %% + %% Be sure to use only 53 bits when multiplying with + %% math:pow(2.0, -N) to avoid rounding which would make + %% "even" floats more probable than "odd". + %% + {V1, R1} = Next(R0), + M1 = V1 bsr (Bits - 56), + if + ?BIT(55) =< M1 -> + %% We have 56 bits - waste 3 + {(M1 bsr 3) * math:pow(2.0, -53), {Alg, R1}}; + ?BIT(54) =< M1 -> + %% We have 55 bits - waste 2 + {(M1 bsr 2) * math:pow(2.0, -54), {Alg, R1}}; + ?BIT(53) =< M1 -> + %% We have 54 bits - waste 1 + {(M1 bsr 1) * math:pow(2.0, -55), {Alg, R1}}; + ?BIT(52) =< M1 -> + %% We have 53 bits - use all + {M1 * math:pow(2.0, -56), {Alg, R1}}; + true -> + %% Need more bits + {V2, R2} = Next(R1), + uniform_real_s(Alg, Next, M1, -56, R2, V2, Bits) + end; +uniform_real_s({#{max:=_, next:=Next} = Alg, R0}) -> + %% Generate a 56 bit number. + %% Ignore the weak low bits for these old algorithms, + %% just produce something reasonable. + %% + %% Be sure to use only 53 bits when multiplying with + %% math:pow(2.0, -N) to avoid rounding which would make + %% "even" floats more probable than "odd". + %% + {V1, R1} = Next(R0), + M1 = ?MASK(56, V1), + if + ?BIT(55) =< M1 -> + %% We have 56 bits - waste 3 + {(M1 bsr 3) * math:pow(2.0, -53), {Alg, R1}}; + ?BIT(54) =< M1 -> + %% We have 55 bits - waste 2 + {(M1 bsr 2) * math:pow(2.0, -54), {Alg, R1}}; + ?BIT(53) =< M1 -> + %% We have 54 bits - waste 1 + {(M1 bsr 1) * math:pow(2.0, -55), {Alg, R1}}; + ?BIT(52) =< M1 -> + %% We have 53 bits - use all + {M1 * math:pow(2.0, -56), {Alg, R1}}; + true -> + %% Need more bits + {V2, R2} = Next(R1), + uniform_real_s(Alg, Next, M1, -56, R2, V2, 56) + end. + +uniform_real_s(Alg, _Next, M0, -1064, R1, V1, Bits) -> % 19*56 + %% This is a very theoretical bottom case. + %% The odds of getting here is about 2^-1008, + %% through a white box test case, or thanks to + %% a malfunctioning PRNG producing 18 56-bit zeros in a row. + %% + %% Fill up to 53 bits, we have at most 52 + B0 = (53 - ?BC(M0, 52)), % Missing bits + {(((M0 bsl B0) bor (V1 bsr (Bits - B0))) * math:pow(2.0, -1064 - B0)), + {Alg, R1}}; +uniform_real_s(Alg, Next, M0, BitNo, R1, V1, Bits) -> + if + %% Optimize the most probable. + %% Fill up to 53 bits. + ?BIT(51) =< M0 -> + %% We have 52 bits in M0 - need 1 + {(((M0 bsl 1) bor (V1 bsr (Bits - 1))) + * math:pow(2.0, BitNo - 1)), + {Alg, R1}}; + ?BIT(50) =< M0 -> + %% We have 51 bits in M0 - need 2 + {(((M0 bsl 2) bor (V1 bsr (Bits - 2))) + * math:pow(2.0, BitNo - 2)), + {Alg, R1}}; + ?BIT(49) =< M0 -> + %% We have 50 bits in M0 - need 3 + {(((M0 bsl 3) bor (V1 bsr (Bits - 3))) + * math:pow(2.0, BitNo - 3)), + {Alg, R1}}; + M0 == 0 -> + M1 = V1 bsr (Bits - 56), + if + ?BIT(55) =< M1 -> + %% We have 56 bits - waste 3 + {(M1 bsr 3) * math:pow(2.0, BitNo - 53), {Alg, R1}}; + ?BIT(54) =< M1 -> + %% We have 55 bits - waste 2 + {(M1 bsr 2) * math:pow(2.0, BitNo - 54), {Alg, R1}}; + ?BIT(53) =< M1 -> + %% We have 54 bits - waste 1 + {(M1 bsr 1) * math:pow(2.0, BitNo - 55), {Alg, R1}}; + ?BIT(52) =< M1 -> + %% We have 53 bits - use all + {M1 * math:pow(2.0, BitNo - 56), {Alg, R1}}; + BitNo =:= -1008 -> + %% Endgame + %% For the last round we can not have 14 zeros or more + %% at the top of M1 because then we will underflow, + %% so we need at least 43 bits + if + ?BIT(42) =< M1 -> + %% We have 43 bits - get the last bits + uniform_real_s(Alg, Next, M1, BitNo - 56, R1); + true -> + %% Would underflow 2^-1022 - start all over + %% + %% We could just crash here since the odds for + %% the PRNG being broken is much higher than + %% for a good PRNG generating this many zeros + %% in a row. Maybe we should write an error + %% report or call this a system limit...? + uniform_real_s({Alg, R1}) + end; + true -> + %% Need more bits + uniform_real_s(Alg, Next, M1, BitNo - 56, R1) + end; + true -> + %% Fill up to 53 bits + B0 = 53 - ?BC(M0, 49), % Number of bits we need to append + {(((M0 bsl B0) bor (V1 bsr (Bits - B0))) + * math:pow(2.0, BitNo - B0)), + {Alg, R1}} + end. +%% +uniform_real_s(#{bits:=Bits} = Alg, Next, M0, BitNo, R0) -> + {V1, R1} = Next(R0), + uniform_real_s(Alg, Next, M0, BitNo, R1, V1, Bits); +uniform_real_s(#{max:=_} = Alg, Next, M0, BitNo, R0) -> + {V1, R1} = Next(R0), + uniform_real_s(Alg, Next, M0, BitNo, R1, ?MASK(56, V1), 56). + +%% 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 +552,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 +579,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 +602,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 +633,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,15 +657,17 @@ 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}). @@ -271,17 +676,56 @@ exsplus_seed({A1, A2, A3}) -> -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* @@ -289,12 +733,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), []}. @@ -317,11 +761,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()}. @@ -332,13 +776,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 @@ -347,9 +968,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) -> @@ -594,3 +1219,42 @@ normal_fi(Indx) -> 1.0214971439701471e-02,8.6165827693987316e-03,7.0508754713732268e-03, 5.5224032992509968e-03,4.0379725933630305e-03,2.6090727461021627e-03, 1.2602859304985975e-03}). + +%%%bitcount64(0) -> 0; +%%%bitcount64(V) -> 1 + bitcount(V, 64). +%%% +%%%-define( +%%% BITCOUNT(V, N), +%%% bitcount(V, N) -> +%%% if +%%% (1 bsl ((N) bsr 1)) =< (V) -> +%%% ((N) bsr 1) + bitcount((V) bsr ((N) bsr 1), ((N) bsr 1)); +%%% true -> +%%% bitcount((V), ((N) bsr 1)) +%%% end). +%%%?BITCOUNT(V, 64); +%%%?BITCOUNT(V, 32); +%%%?BITCOUNT(V, 16); +%%%?BITCOUNT(V, 8); +%%%?BITCOUNT(V, 4); +%%%?BITCOUNT(V, 2); +%%%bitcount(_, 1) -> 0. + +bc64(V) -> ?BC(V, 64). + +%% Linear from high bit - higher probability first gives faster execution +bc(V, B, N) when B =< V -> N; +bc(V, B, N) -> bc(V, B bsr 1, N - 1). + +make_float(S, E, M) -> + <<F/float>> = <<S:1, E:11, M:52>>, + F. + +float2str(N) -> + <<S:1, E:11, M:52>> = <<(float(N))/float>>, + lists:flatten( + io_lib:format( + "~c~c.~13.16.0bE~b", + [case S of 1 -> $-; 0 -> $+ end, + case E of 0 -> $0; _ -> $1 end, + M, E - 16#3ff])). 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 80bfe38970..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(), diff --git a/lib/stdlib/src/sets.erl b/lib/stdlib/src/sets.erl index cd435ff49c..8adb9016e2 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-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. @@ -37,7 +37,7 @@ -module(sets). %% Standard interface. --export([new/0,is_set/1,size/1,to_list/1,from_list/1]). +-export([new/0,is_set/1,size/1,is_empty/1,to_list/1,from_list/1]). -export([is_element/2,add_element/2,del_element/2]). -export([union/2,union/1,intersection/2,intersection/1]). -export([is_disjoint/2]). @@ -96,6 +96,12 @@ is_set(_) -> false. Set :: set(). size(S) -> S#set.size. +%% is_empty(Set) -> boolean(). +%% Return 'true' if Set is an empty set, otherwise 'false'. +-spec is_empty(Set) -> boolean() when + Set :: set(). +is_empty(S) -> S#set.size=:=0. + %% to_list(Set) -> [Elem]. %% Return the elements in Set as a list. -spec to_list(Set) -> List when @@ -128,14 +134,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 +150,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 +291,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 +355,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 +366,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 ce1d9eb0ff..c73cf22943 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. @@ -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 = erl_eval: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); + erl_eval:extended_parse_exprs(Toks); {eof,_EndPos} -> eof; {error,ErrorInfo,_EndPos} -> @@ -588,7 +589,7 @@ report_exception(Class, Severity, {Reason,Stacktrace}, RT) -> PF = fun(Term, I1) -> pp(Term, I1, RT) end, SF = fun(M, _F, _A) -> (M =:= erl_eval) or (M =:= ?MODULE) end, Enc = encoding(), - Str = lib:format_exception(I, Class, Reason, Stacktrace, SF, PF, Enc), + Str = erl_error:format_exception(I, Class, Reason, Stacktrace, SF, PF, Enc), io:requests([{put_chars, latin1, Tag}, {put_chars, unicode, Str}, nl]). @@ -644,8 +645,7 @@ eval_exprs(Es, Shell, Bs0, RT, Lf, Ef, W) -> catch exit:normal -> exit(normal); - Class:Reason -> - Stacktrace = erlang:get_stacktrace(), + Class:Reason:Stacktrace -> M = {self(),Class,{Reason,Stacktrace}}, case do_catch(Class, Reason) of true -> @@ -700,7 +700,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 +728,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 +738,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 +776,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) -> @@ -796,8 +806,8 @@ restrict_handlers(RShMod, Shell, RT) -> -define(BAD_RETURN(M, F, V), try erlang:error(reason) - catch _:_ -> erlang:raise(exit, {restricted_shell_bad_return,V}, - [{M,F,3} | erlang:get_stacktrace()]) + catch _:_:S -> erlang:raise(exit, {restricted_shell_bad_return,V}, + [{M,F,3} | S]) end). local_allowed(F, As, RShMod, Bs, Shell, RT) when is_atom(F) -> @@ -917,9 +927,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 +975,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} -> @@ -1081,6 +1092,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([]) -> []. @@ -1232,22 +1245,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) -> @@ -1403,7 +1416,7 @@ pp(V, I, D, RT) -> true end, io_lib_pretty:print(V, ([{column, I}, {line_length, columns()}, - {depth, D}, {max_chars, ?CHAR_MAX}, + {depth, D}, {line_max_chars, ?CHAR_MAX}, {strings, Strings}, {record_print_fun, record_print_fun(RT)}] ++ enc())). @@ -1413,9 +1426,11 @@ columns() -> {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 @@ -1445,7 +1460,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..5e8c1a43ea 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-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. @@ -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()]), @@ -187,7 +187,7 @@ start_link(Host, Name, Args) -> start(Host, Name, Args, self()). start(Host0, Name, Args, LinkTo) -> - Prog = lib:progname(), + Prog = progname(), start(Host0, Name, Args, LinkTo, Prog). start(Host0, Name, Args, LinkTo, Prog) -> @@ -289,17 +289,13 @@ 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, " -s slave slave_start ", node(), " ", Waiter, " ", Args]), - case after_char($@, atom_to_list(node())) of Host -> {ok, BasicCmd}; @@ -312,23 +308,14 @@ 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)))]. +%% Return the name of the script that starts (this) erlang +progname() -> + case init:get_argument(progname) of + {ok, [[Prog]]} -> + Prog; + _Other -> + "no_prog_name" + end. %% This is an attempt to distinguish between spaces in the program %% path and spaces that separate arguments. The program is quoted to @@ -338,10 +325,10 @@ mk_ose_prog(Prog) -> %% (through start/5) or if the -program switch to beam is used and %% includes arguments (typically done by cerl in OTP test environment %% in order to ensure that slave/peer nodes are started with the same -%% emulator and flags as the test node. The return from lib:progname() +%% emulator and flags as the test node. The result from progname() %% could then typically be '/<full_path_to>/cerl -gcov'). quote_progname(Progname) -> - do_quote_progname(string:tokens(to_list(Progname)," ")). + do_quote_progname(string:lexemes(to_list(Progname)," ")). do_quote_progname([Prog]) -> "\""++Prog++"\""; 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 b8a7973cf2..cd09872b87 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-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. @@ -31,7 +31,6 @@ dets_server, dets_sup, dets_utils, - dets_v8, dets_v9, dict, digraph, @@ -40,9 +39,11 @@ edlin_expand, epp, eval_bits, + erl_abstract_code, erl_anno, erl_bits, erl_compile, + erl_error, erl_eval, erl_expand_records, erl_internal, @@ -65,12 +66,12 @@ gen_event, gen_fsm, gen_server, + gen_statem, io, io_lib, io_lib_format, io_lib_fread, io_lib_pretty, - lib, lists, log_mf_h, maps, @@ -99,13 +100,15 @@ sys, timer, unicode, + unicode_util, + uri_string, win32reg, zip]}, {registered,[timer_server,rsh_starter,take_over_monitor,pool_master, dets]}, {applications, [kernel]}, {env, []}, - {runtime_dependencies, ["sasl-2.6","kernel-4.1","erts-7.3","crypto-3.3", + {runtime_dependencies, ["sasl-3.0","kernel-6.0","erts-10.0","crypto-3.3", "compiler-5.0"]} ]}. diff --git a/lib/stdlib/src/stdlib.appup.src b/lib/stdlib/src/stdlib.appup.src index 8a313591a7..8c0b186288 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,9 +18,11 @@ %% %CopyrightEnd% {"%VSN%", %% Up from - max one major revision back - [{<<"2\\.[5-8](\\.[0-9]+)*">>,[restart_new_emulator]}, % OTP-18.* - {<<"2\\.[0-4](\\.[0-9]+)*">>,[restart_new_emulator]}], % 17.0-17.5 + [{<<"3\\.4(\\.[0-9]+)*">>,[restart_new_emulator]}, % OTP-20.* + {<<"3\\.5(\\.[0-9]+)*">>,[restart_new_emulator]}, % OTP-21.0 + {<<"3\\.6(\\.[0-9]+)*">>,[restart_new_emulator]}],% OTP-21.1 %% Down to - max one major revision back - [{<<"2\\.[5-8](\\.[0-9]+)*">>,[restart_new_emulator]}, % OTP-18.* - {<<"2\\.[0-4](\\.[0-9]+)*">>,[restart_new_emulator]}] % 17.0-17.5 + [{<<"3\\.4(\\.[0-9]+)*">>,[restart_new_emulator]}, % OTP-20.* + {<<"3\\.5(\\.[0-9]+)*">>,[restart_new_emulator]}, % OTP-21.0 + {<<"3\\.6(\\.[0-9]+)*">>,[restart_new_emulator]}] % OTP-21.1 }. diff --git a/lib/stdlib/src/string.erl b/lib/stdlib/src/string.erl index 07659ed812..2939e78d9d 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-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. @@ -17,43 +17,1707 @@ %% %% %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]). -%%% BIFs +-type grapheme_cluster() :: char() | [char()]. +-type direction() :: 'leading' | 'trailing'. --export([to_float/1, to_integer/1]). +-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]). --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) -> + try uppercase_list(CD, false) + catch unchanged -> CD + end; +uppercase(<<CP1/utf8, Rest/binary>>=Orig) -> + try uppercase_bin(CP1, Rest, false) of + List -> unicode:characters_to_binary(List) + catch unchanged -> Orig + end; +uppercase(<<>>) -> + <<>>. + +%% Lowercase all chars in Str +-spec lowercase(String::unicode:chardata()) -> unicode:chardata(). +lowercase(CD) when is_list(CD) -> + try lowercase_list(CD, false) + catch unchanged -> CD + end; +lowercase(<<CP1/utf8, Rest/binary>>=Orig) -> + try lowercase_bin(CP1, Rest, false) of + List -> unicode:characters_to_binary(List) + catch unchanged -> Orig + end; +lowercase(<<>>) -> + <<>>. + +%% 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) -> + try casefold_list(CD, false) + catch unchanged -> CD + end; +casefold(<<CP1/utf8, Rest/binary>>=Orig) -> + try casefold_bin(CP1, Rest, false) of + List -> unicode:characters_to_binary(List) + catch unchanged -> Orig + end; +casefold(<<>>) -> + <<>>. + +-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([CP1|[CP2|_]=Cont], _Changed) when $a =< CP1, CP1 =< $z, CP2 < 256 -> + [CP1-32|uppercase_list(Cont, true)]; +uppercase_list([CP1|[CP2|_]=Cont], Changed) when CP1 < 128, CP2 < 256 -> + [CP1|uppercase_list(Cont, Changed)]; +uppercase_list([], true) -> + []; +uppercase_list([], false) -> + throw(unchanged); +uppercase_list(CPs0, Changed) -> + case unicode_util:uppercase(CPs0) of + [Char|CPs] when Char =:= hd(CPs0) -> [Char|uppercase_list(CPs, Changed)]; + [Char|CPs] -> append(Char,uppercase_list(CPs, true)); + [] -> uppercase_list([], Changed) + end. + +uppercase_bin(CP1, <<CP2/utf8, Bin/binary>>, _Changed) + when $a =< CP1, CP1 =< $z, CP2 < 256 -> + [CP1-32|uppercase_bin(CP2, Bin, true)]; +uppercase_bin(CP1, <<CP2/utf8, Bin/binary>>, Changed) + when CP1 < 128, CP2 < 256 -> + [CP1|uppercase_bin(CP2, Bin, Changed)]; +uppercase_bin(CP1, Bin, Changed) -> + case unicode_util:uppercase([CP1|Bin]) of + [CP1|CPs] -> + case unicode_util:cp(CPs) of + [Next|Rest] -> + [CP1|uppercase_bin(Next, Rest, Changed)]; + [] when Changed -> + [CP1]; + [] -> + throw(unchanged) + end; + [Char|CPs] -> + case unicode_util:cp(CPs) of + [Next|Rest] -> + [Char|uppercase_bin(Next, Rest, true)]; + [] -> + [Char] + end + end. + +lowercase_list([CP1|[CP2|_]=Cont], _Changed) when $A =< CP1, CP1 =< $Z, CP2 < 256 -> + [CP1+32|lowercase_list(Cont, true)]; +lowercase_list([CP1|[CP2|_]=Cont], Changed) when CP1 < 128, CP2 < 256 -> + [CP1|lowercase_list(Cont, Changed)]; +lowercase_list([], true) -> + []; +lowercase_list([], false) -> + throw(unchanged); +lowercase_list(CPs0, Changed) -> + case unicode_util:lowercase(CPs0) of + [Char|CPs] when Char =:= hd(CPs0) -> [Char|lowercase_list(CPs, Changed)]; + [Char|CPs] -> append(Char,lowercase_list(CPs, true)); + [] -> lowercase_list([], Changed) + end. + +lowercase_bin(CP1, <<CP2/utf8, Bin/binary>>, _Changed) + when $A =< CP1, CP1 =< $Z, CP2 < 256 -> + [CP1+32|lowercase_bin(CP2, Bin, true)]; +lowercase_bin(CP1, <<CP2/utf8, Bin/binary>>, Changed) + when CP1 < 128, CP2 < 256 -> + [CP1|lowercase_bin(CP2, Bin, Changed)]; +lowercase_bin(CP1, Bin, Changed) -> + case unicode_util:lowercase([CP1|Bin]) of + [CP1|CPs] -> + case unicode_util:cp(CPs) of + [Next|Rest] -> + [CP1|lowercase_bin(Next, Rest, Changed)]; + [] when Changed -> + [CP1]; + [] -> + throw(unchanged) + end; + [Char|CPs] -> + case unicode_util:cp(CPs) of + [Next|Rest] -> + [Char|lowercase_bin(Next, Rest, true)]; + [] -> + [Char] + end + end. + +casefold_list([CP1|[CP2|_]=Cont], _Changed) when $A =< CP1, CP1 =< $Z, CP2 < 256 -> + [CP1+32|casefold_list(Cont, true)]; +casefold_list([CP1|[CP2|_]=Cont], Changed) when CP1 < 128, CP2 < 256 -> + [CP1|casefold_list(Cont, Changed)]; +casefold_list([], true) -> + []; +casefold_list([], false) -> + throw(unchanged); +casefold_list(CPs0, Changed) -> + case unicode_util:casefold(CPs0) of + [Char|CPs] when Char =:= hd(CPs0) -> [Char|casefold_list(CPs, Changed)]; + [Char|CPs] -> append(Char,casefold_list(CPs, true)); + [] -> casefold_list([], Changed) + end. + +casefold_bin(CP1, <<CP2/utf8, Bin/binary>>, _Changed) + when $A =< CP1, CP1 =< $Z, CP2 < 256 -> + [CP1+32|casefold_bin(CP2, Bin, true)]; +casefold_bin(CP1, <<CP2/utf8, Bin/binary>>, Changed) + when CP1 < 128, CP2 < 256 -> + [CP1|casefold_bin(CP2, Bin, Changed)]; +casefold_bin(CP1, Bin, Changed) -> + case unicode_util:casefold([CP1|Bin]) of + [CP1|CPs] -> + case unicode_util:cp(CPs) of + [Next|Rest] -> + [CP1|casefold_bin(Next, Rest, Changed)]; + [] when Changed -> + [CP1]; + [] -> + throw(unchanged) + end; + [Char|CPs] -> + case unicode_util:cp(CPs) of + [Next|Rest] -> + [Char|casefold_bin(Next, Rest, true)]; + [] -> + [Char] + end + 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 +1727,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 +1791,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 +1806,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 +1893,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 +2006,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 +2023,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 +2033,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 +2072,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 +2097,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 +2124,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 cecdebd0c8..1ac7334830 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-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. @@ -30,12 +30,25 @@ %% Internal exports -export([init/1, handle_call/3, handle_cast/2, handle_info/2, - terminate/2, code_change/3]). --export([try_again_restart/2]). + terminate/2, code_change/3, format_status/2]). %% For release_handler only -export([get_callback_module/1]). +-include("logger.hrl"). + +-define(report_error(Error, Reason, Child, SupName), + ?LOG_ERROR(#{label=>{supervisor,Error}, + report=>[{supervisor,SupName}, + {errorContext,Error}, + {reason,Reason}, + {offender,extract_child(Child)}]}, + #{domain=>[otp,sasl], + report_cb=>fun logger:format_otp_report/1, + logger_formatter=>#{title=>"SUPERVISOR REPORT"}, + error_logger=>#{tag=>error_report, + type=>supervisor_report}})). + %%-------------------------------------------------------------------------- -export_type([sup_flags/0, child_spec/0, startchild_ret/0, strategy/0]). @@ -57,8 +70,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 @@ -79,6 +92,7 @@ | {RestartStrategy :: strategy(), Intensity :: non_neg_integer(), Period :: pos_integer()}. +-type children() :: {Ids :: [child_id()], Db :: #{child_id() => child_rec()}}. %%-------------------------------------------------------------------------- %% Defaults @@ -96,7 +110,7 @@ pid = undefined :: child() | {restarting, pid() | undefined} | [pid()], - name :: child_id(), + id :: child_id(), mfargs :: mfargs(), restart_type :: restart(), shutdown :: shutdown(), @@ -104,17 +118,14 @@ modules = [] :: modules()}). -type child_rec() :: #child{}. --define(DICTS, dict). --define(DICT, dict:dict). --define(SETS, sets). --define(SET, sets:set). - -record(state, {name, - strategy :: strategy(), - children = [] :: [child_rec()], - dynamics :: ?DICT(pid(), list()) | ?SET(pid()), - intensity :: non_neg_integer(), - period :: pos_integer(), + strategy :: strategy() | 'undefined', + children = {[],#{}} :: children(), % Ids in start order + dynamics :: {'maps', #{pid() => list()}} + | {'sets', sets:set(pid())} + | 'undefined', + intensity :: non_neg_integer() | 'undefined', + period :: pos_integer() | 'undefined', restarts = [], dynamic_restarts = 0 :: non_neg_integer(), module, @@ -122,6 +133,9 @@ -type state() :: #state{}. -define(is_simple(State), State#state.strategy =:= simple_one_for_one). +-define(is_temporary(_Child_), _Child_#child.restart_type=:=temporary). +-define(is_transient(_Child_), _Child_#child.restart_type=:=transient). +-define(is_permanent(_Child_), _Child_#child.restart_type=:=permanent). -callback init(Args :: term()) -> {ok, {SupFlags :: sup_flags(), [ChildSpec :: child_spec()]}} @@ -177,16 +191,16 @@ start_child(Supervisor, ChildSpec) -> | {'error', Error}, Error :: 'running' | 'restarting' | 'not_found' | 'simple_one_for_one' | term(). -restart_child(Supervisor, Name) -> - call(Supervisor, {restart_child, Name}). +restart_child(Supervisor, Id) -> + call(Supervisor, {restart_child, Id}). -spec delete_child(SupRef, Id) -> Result when SupRef :: sup_ref(), Id :: child_id(), Result :: 'ok' | {'error', Error}, Error :: 'running' | 'restarting' | 'not_found' | 'simple_one_for_one'. -delete_child(Supervisor, Name) -> - call(Supervisor, {delete_child, Name}). +delete_child(Supervisor, Id) -> + call(Supervisor, {delete_child, Id}). %%----------------------------------------------------------------- %% Func: terminate_child/2 @@ -200,16 +214,16 @@ delete_child(Supervisor, Name) -> Id :: pid() | child_id(), Result :: 'ok' | {'error', Error}, Error :: 'not_found' | 'simple_one_for_one'. -terminate_child(Supervisor, Name) -> - call(Supervisor, {terminate_child, Name}). +terminate_child(Supervisor, Id) -> + call(Supervisor, {terminate_child, Id}). -spec get_childspec(SupRef, Id) -> Result when SupRef :: sup_ref(), Id :: pid() | child_id(), Result :: {'ok', child_spec()} | {'error', Error}, Error :: 'not_found'. -get_childspec(Supervisor, Name) -> - call(Supervisor, {get_childspec, Name}). +get_childspec(Supervisor, Id) -> + call(Supervisor, {get_childspec, Id}). -spec which_children(SupRef) -> [{Id,Child,Type,Modules}] when SupRef :: sup_ref(), @@ -244,17 +258,6 @@ check_childspecs(ChildSpecs) when is_list(ChildSpecs) -> check_childspecs(X) -> {error, {badarg, X}}. %%%----------------------------------------------------------------- -%%% Called by timer:apply_after from restart/2 --spec try_again_restart(SupRef, Child) -> ok when - SupRef :: sup_ref(), - Child :: child_id() | pid(). -try_again_restart(Supervisor, Child) -> - cast(Supervisor, {try_again_restart, Child}). - -cast(Supervisor, Req) -> - gen_server:cast(Supervisor, Req). - -%%%----------------------------------------------------------------- %%% Called by release_handler during upgrade -spec get_callback_module(Pid) -> Module when Pid :: pid(), @@ -262,8 +265,13 @@ cast(Supervisor, Req) -> get_callback_module(Pid) -> {status, _Pid, {module, _Mod}, [_PDict, _SysState, _Parent, _Dbg, Misc]} = sys:get_status(Pid), - [_Header, _Data, {data, [{"State", State}]}] = Misc, - State#state.module. + case lists:keyfind(supervisor, 1, Misc) of + {supervisor, [{"Callback", Mod}]} -> + Mod; + _ -> + [_Header, _Data, {data, [{"State", State}]} | _] = Misc, + State#state.module + end. %%% --------------------------------------------------- %%% @@ -318,7 +326,7 @@ init_children(State, StartSpec) -> init_dynamic(State, [StartSpec]) -> case check_startspec([StartSpec]) of {ok, Children} -> - {ok, State#state{children = Children}}; + {ok, dyn_init(State#state{children = Children})}; Error -> {stop, {start_spec, Error}} end; @@ -327,35 +335,34 @@ init_dynamic(_State, StartSpec) -> %%----------------------------------------------------------------- %% Func: start_children/2 -%% Args: Children = [child_rec()] in start order +%% Args: Children = children() % Ids in start order %% SupName = {local, atom()} | {global, atom()} | {pid(), Mod} -%% Purpose: Start all children. The new list contains #child's +%% Purpose: Start all children. The new map contains #child's %% with pids. %% Returns: {ok, NChildren} | {error, NChildren, Reason} -%% NChildren = [child_rec()] in termination order (reversed -%% start order) +%% NChildren = children() % Ids in termination order +%% (reversed start order) %%----------------------------------------------------------------- -start_children(Children, SupName) -> start_children(Children, [], SupName). - -start_children([Child|Chs], NChildren, SupName) -> - case do_start_child(SupName, Child) of - {ok, undefined} when Child#child.restart_type =:= temporary -> - start_children(Chs, NChildren, SupName); - {ok, Pid} -> - start_children(Chs, [Child#child{pid = Pid}|NChildren], SupName); - {ok, Pid, _Extra} -> - start_children(Chs, [Child#child{pid = Pid}|NChildren], SupName); - {error, Reason} -> - report_error(start_error, Reason, Child, SupName), - {error, lists:reverse(Chs) ++ [Child | NChildren], - {failed_to_start_child,Child#child.name,Reason}} - end; -start_children([], NChildren, _SupName) -> - {ok, NChildren}. +start_children(Children, SupName) -> + Start = + fun(Id,Child) -> + case do_start_child(SupName, Child) of + {ok, undefined} when ?is_temporary(Child) -> + remove; + {ok, Pid} -> + {update,Child#child{pid = Pid}}; + {ok, Pid, _Extra} -> + {update,Child#child{pid = Pid}}; + {error, Reason} -> + ?report_error(start_error, Reason, Child, SupName), + {abort,{failed_to_start_child,Id,Reason}} + end + end, + children_map(Start,Children). do_start_child(SupName, Child) -> #child{mfargs = {M, F, Args}} = Child, - case catch apply(M, F, Args) of + case do_start_child_i(M, F, Args) of {ok, Pid} when is_pid(Pid) -> NChild = Child#child{pid = Pid}, report_progress(NChild, SupName), @@ -364,10 +371,8 @@ do_start_child(SupName, Child) -> NChild = Child#child{pid = Pid}, report_progress(NChild, SupName), {ok, Pid, Extra}; - ignore -> - {ok, undefined}; - {error, What} -> {error, What}; - What -> {error, What} + Other -> + Other end. do_start_child_i(M, F, A) -> @@ -393,17 +398,17 @@ do_start_child_i(M, F, A) -> -spec handle_call(call(), term(), state()) -> {'reply', term(), state()}. handle_call({start_child, EArgs}, _From, State) when ?is_simple(State) -> - Child = hd(State#state.children), + Child = get_dynamic_child(State), #child{mfargs = {M, F, A}} = Child, Args = A ++ EArgs, case do_start_child_i(M, F, Args) of {ok, undefined} -> {reply, {ok, undefined}, State}; {ok, Pid} -> - NState = save_dynamic_child(Child#child.restart_type, Pid, Args, State), + NState = dyn_store(Pid, Args, State), {reply, {ok, Pid}, NState}; {ok, Pid, Extra} -> - NState = save_dynamic_child(Child#child.restart_type, Pid, Args, State), + NState = dyn_store(Pid, Args, State), {reply, {ok, Pid, Extra}, NState}; What -> {reply, What, State} @@ -419,121 +424,94 @@ handle_call({start_child, ChildSpec}, _From, State) -> end; %% terminate_child for simple_one_for_one can only be done with pid -handle_call({terminate_child, Name}, _From, State) when not is_pid(Name), - ?is_simple(State) -> +handle_call({terminate_child, Id}, _From, State) when not is_pid(Id), + ?is_simple(State) -> {reply, {error, simple_one_for_one}, State}; -handle_call({terminate_child, Name}, _From, State) -> - case get_child(Name, State, ?is_simple(State)) of - {value, Child} -> - case do_terminate(Child, State#state.name) of - #child{restart_type=RT} when RT=:=temporary; ?is_simple(State) -> - {reply, ok, state_del_child(Child, State)}; - NChild -> - {reply, ok, replace_child(NChild, State)} - end; - false -> +handle_call({terminate_child, Id}, _From, State) -> + case find_child(Id, State) of + {ok, Child} -> + do_terminate(Child, State#state.name), + {reply, ok, del_child(Child, State)}; + error -> {reply, {error, not_found}, State} end; %% restart_child request is invalid for simple_one_for_one supervisors -handle_call({restart_child, _Name}, _From, State) when ?is_simple(State) -> +handle_call({restart_child, _Id}, _From, State) when ?is_simple(State) -> {reply, {error, simple_one_for_one}, State}; -handle_call({restart_child, Name}, _From, State) -> - case get_child(Name, State) of - {value, Child} when Child#child.pid =:= undefined -> +handle_call({restart_child, Id}, _From, State) -> + case find_child(Id, State) of + {ok, Child} when Child#child.pid =:= undefined -> case do_start_child(State#state.name, Child) of {ok, Pid} -> - NState = replace_child(Child#child{pid = Pid}, State), + NState = set_pid(Pid, Id, State), {reply, {ok, Pid}, NState}; {ok, Pid, Extra} -> - NState = replace_child(Child#child{pid = Pid}, State), + NState = set_pid(Pid, Id, State), {reply, {ok, Pid, Extra}, NState}; Error -> {reply, Error, State} end; - {value, #child{pid=?restarting(_)}} -> + {ok, #child{pid=?restarting(_)}} -> {reply, {error, restarting}, State}; - {value, _} -> + {ok, _} -> {reply, {error, running}, State}; _ -> {reply, {error, not_found}, State} end; %% delete_child request is invalid for simple_one_for_one supervisors -handle_call({delete_child, _Name}, _From, State) when ?is_simple(State) -> +handle_call({delete_child, _Id}, _From, State) when ?is_simple(State) -> {reply, {error, simple_one_for_one}, State}; -handle_call({delete_child, Name}, _From, State) -> - case get_child(Name, State) of - {value, Child} when Child#child.pid =:= undefined -> - NState = remove_child(Child, State), +handle_call({delete_child, Id}, _From, State) -> + case find_child(Id, State) of + {ok, Child} when Child#child.pid =:= undefined -> + NState = remove_child(Id, State), {reply, ok, NState}; - {value, #child{pid=?restarting(_)}} -> + {ok, #child{pid=?restarting(_)}} -> {reply, {error, restarting}, State}; - {value, _} -> + {ok, _} -> {reply, {error, running}, State}; _ -> {reply, {error, not_found}, State} end; -handle_call({get_childspec, Name}, _From, State) -> - case get_child(Name, State, ?is_simple(State)) of - {value, Child} -> +handle_call({get_childspec, Id}, _From, State) -> + case find_child(Id, State) of + {ok, Child} -> {reply, {ok, child_to_spec(Child)}, State}; - false -> + error -> {reply, {error, not_found}, State} end; -handle_call(which_children, _From, #state{children = [#child{restart_type = temporary, - child_type = CT, - modules = Mods}]} = - State) when ?is_simple(State) -> - Reply = lists:map(fun(Pid) -> {undefined, Pid, CT, Mods} end, - ?SETS:to_list(dynamics_db(temporary, State#state.dynamics))), - {reply, Reply, State}; - -handle_call(which_children, _From, #state{children = [#child{restart_type = RType, - child_type = CT, - modules = Mods}]} = - State) when ?is_simple(State) -> - Reply = lists:map(fun({?restarting(_),_}) -> {undefined,restarting,CT,Mods}; - ({Pid, _}) -> {undefined, Pid, CT, Mods} end, - ?DICTS:to_list(dynamics_db(RType, State#state.dynamics))), +handle_call(which_children, _From, State) when ?is_simple(State) -> + #child{child_type = CT,modules = Mods} = get_dynamic_child(State), + Reply = dyn_map(fun(?restarting(_)) -> {undefined, restarting, CT, Mods}; + (Pid) -> {undefined, Pid, CT, Mods} + end, State), {reply, Reply, State}; handle_call(which_children, _From, State) -> Resp = - lists:map(fun(#child{pid = ?restarting(_), name = Name, - child_type = ChildType, modules = Mods}) -> - {Name, restarting, ChildType, Mods}; - (#child{pid = Pid, name = Name, - child_type = ChildType, modules = Mods}) -> - {Name, Pid, ChildType, Mods} - end, - State#state.children), + children_to_list( + fun(Id,#child{pid = ?restarting(_), + child_type = ChildType, modules = Mods}) -> + {Id, restarting, ChildType, Mods}; + (Id,#child{pid = Pid, + child_type = ChildType, modules = Mods}) -> + {Id, Pid, ChildType, Mods} + end, + State#state.children), {reply, Resp, State}; - -handle_call(count_children, _From, #state{children = [#child{restart_type = temporary, - child_type = CT}]} = State) +handle_call(count_children, _From, #state{dynamic_restarts = Restarts} = State) when ?is_simple(State) -> - Sz = ?SETS:size(dynamics_db(temporary, State#state.dynamics)), - Reply = case CT of - 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{dynamic_restarts = Restarts, - children = [#child{restart_type = RType, - child_type = CT}]} = State) - when ?is_simple(State) -> - Sz = ?DICTS:size(dynamics_db(RType, State#state.dynamics)), - Active = Sz - Restarts, + #child{child_type = CT} = get_dynamic_child(State), + Sz = dyn_size(State), + Active = Sz - Restarts, % Restarts is always 0 for temporary children Reply = case CT of supervisor -> [{specs, 1}, {active, Active}, {supervisors, Sz}, {workers, 0}]; @@ -545,16 +523,15 @@ handle_call(count_children, _From, #state{dynamic_restarts = Restarts, handle_call(count_children, _From, State) -> %% Specs and children are together on the children list... {Specs, Active, Supers, Workers} = - lists:foldl(fun(Child, Counts) -> - count_child(Child, Counts) - end, {0,0,0,0}, State#state.children), + children_fold(fun(_Id, Child, Counts) -> + count_child(Child, Counts) + end, {0,0,0,0}, State#state.children), %% Reformat counts to a property list. Reply = [{specs, Specs}, {active, Active}, {supervisors, Supers}, {workers, Workers}], {reply, Reply, State}. - count_child(#child{pid = Pid, child_type = worker}, {Specs, Active, Supers, Workers}) -> case is_pid(Pid) andalso is_process_alive(Pid) of @@ -568,34 +545,15 @@ count_child(#child{pid = Pid, child_type = supervisor}, false -> {Specs+1, Active, Supers+1, Workers} 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()) -> +-spec handle_cast({try_again_restart, child_id() | {'restarting',pid()}}, state()) -> {'noreply', state()} | {stop, shutdown, state()}. -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 - {ok, Args} -> - {M, F, _} = Child#child.mfargs, - NChild = Child#child{pid = RPid, mfargs = {M, F, Args}}, - case restart(NChild,State) of - {ok, State1} -> - {noreply, State1}; - {shutdown, State1} -> - {stop, shutdown, State1} - end; - error -> - {noreply, State} - end; - -handle_cast({try_again_restart,Name}, State) -> - case lists:keyfind(Name,#child.name,State#state.children) of - Child = #child{pid=?restarting(_)} -> +handle_cast({try_again_restart,TryAgainId}, State) -> + case find_child_and_args(TryAgainId, State) of + {ok, Child = #child{pid=?restarting(_)}} -> case restart(Child,State) of {ok, State1} -> {noreply, State1}; @@ -621,8 +579,9 @@ handle_info({'EXIT', Pid, Reason}, State) -> end; handle_info(Msg, State) -> - error_logger:error_msg("Supervisor received unexpected message: ~p~n", - [Msg]), + ?LOG_ERROR("Supervisor received unexpected message: ~tp~n",[Msg], + #{domain=>[otp], + error_logger=>#{tag=>error}}), {noreply, State}. %% @@ -630,10 +589,8 @@ handle_info(Msg, State) -> %% -spec terminate(term(), state()) -> 'ok'. -terminate(_Reason, #state{children=[Child]} = State) when ?is_simple(State) -> - terminate_dynamic_children(Child, dynamics_db(Child#child.restart_type, - State#state.dynamics), - State#state.name); +terminate(_Reason, State) when ?is_simple(State) -> + terminate_dynamic_children(State); terminate(_Reason, State) -> terminate_children(State#state.children, State#state.name). @@ -668,8 +625,8 @@ code_change(_, State, _) -> update_childspec(State, StartSpec) when ?is_simple(State) -> case check_startspec(StartSpec) of - {ok, [Child]} -> - {ok, State#state{children = [Child]}}; + {ok, {[_],_}=Children} -> + {ok, State#state{children = Children}}; Error -> {error, Error} end; @@ -683,39 +640,36 @@ update_childspec(State, StartSpec) -> {error, Error} end. -update_childspec1([Child|OldC], Children, KeepOld) -> - case update_chsp(Child, Children) of - {ok,NewChildren} -> - update_childspec1(OldC, NewChildren, KeepOld); +update_childspec1({[Id|OldIds], OldDb}, {Ids,Db}, KeepOld) -> + case update_chsp(maps:get(Id,OldDb), Db) of + {ok,NewDb} -> + update_childspec1({OldIds,OldDb}, {Ids,NewDb}, KeepOld); false -> - update_childspec1(OldC, Children, [Child|KeepOld]) + update_childspec1({OldIds,OldDb}, {Ids,Db}, [Id|KeepOld]) end; -update_childspec1([], Children, KeepOld) -> +update_childspec1({[],OldDb}, {Ids,Db}, KeepOld) -> + KeepOldDb = maps:with(KeepOld,OldDb), %% Return them in (kept) reverse start order. - lists:reverse(Children ++ KeepOld). - -update_chsp(OldCh, Children) -> - case lists:map(fun(Ch) when OldCh#child.name =:= Ch#child.name -> - Ch#child{pid = OldCh#child.pid}; - (Ch) -> - Ch - end, - Children) of - Children -> - false; % OldCh not found in new spec. - NewC -> - {ok, NewC} + {lists:reverse(Ids ++ KeepOld),maps:merge(KeepOldDb,Db)}. + +update_chsp(#child{id=Id}=OldChild, NewDb) -> + case maps:find(Id, NewDb) of + {ok,Child} -> + {ok,NewDb#{Id => Child#child{pid = OldChild#child.pid}}}; + error -> % Id not found in new spec. + false end. + %%% --------------------------------------------------- %%% Start a new child. %%% --------------------------------------------------- handle_start_child(Child, State) -> - case get_child(Child#child.name, State) of - false -> + case find_child(Child#child.id, State) of + error -> case do_start_child(State#state.name, Child) of - {ok, undefined} when Child#child.restart_type =:= temporary -> + {ok, undefined} when ?is_temporary(Child) -> {{ok, undefined}, State}; {ok, Pid} -> {{ok, Pid}, save_child(Child#child{pid = Pid}, State)}; @@ -724,9 +678,9 @@ handle_start_child(Child, State) -> {error, What} -> {{error, {What, Child}}, State} end; - {value, OldChild} when is_pid(OldChild#child.pid) -> + {ok, OldChild} when is_pid(OldChild#child.pid) -> {{error, {already_started, OldChild#child.pid}}, State}; - {value, _OldChild} -> + {ok, _OldChild} -> {{error, already_present}, State} end. @@ -735,192 +689,157 @@ handle_start_child(Child, State) -> %%% Returns: {ok, state()} | {shutdown, 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 - {ok, Args} -> - {M, F, _} = Child#child.mfargs, - NChild = Child#child{pid = Pid, mfargs = {M, F, Args}}, - do_restart(RestartType, Reason, NChild, State); - error -> - {ok, State} - end; - restart_child(Pid, Reason, State) -> - Children = State#state.children, - case lists:keyfind(Pid, #child.pid, Children) of - #child{restart_type = RestartType} = Child -> - do_restart(RestartType, Reason, Child, State); - false -> + case find_child_and_args(Pid, State) of + {ok, Child} -> + do_restart(Reason, Child, State); + error -> {ok, State} end. -do_restart(permanent, Reason, Child, State) -> - report_error(child_terminated, Reason, Child, State#state.name), +do_restart(Reason, Child, State) when ?is_permanent(Child) -> + ?report_error(child_terminated, Reason, Child, State#state.name), restart(Child, State); -do_restart(_, normal, Child, State) -> - NState = state_del_child(Child, State), +do_restart(normal, Child, State) -> + NState = del_child(Child, State), {ok, NState}; -do_restart(_, shutdown, Child, State) -> - NState = state_del_child(Child, State), +do_restart(shutdown, Child, State) -> + NState = del_child(Child, State), {ok, NState}; -do_restart(_, {shutdown, _Term}, Child, State) -> - NState = state_del_child(Child, State), +do_restart({shutdown, _Term}, Child, State) -> + NState = del_child(Child, State), {ok, NState}; -do_restart(transient, Reason, Child, State) -> - report_error(child_terminated, Reason, Child, State#state.name), +do_restart(Reason, Child, State) when ?is_transient(Child) -> + ?report_error(child_terminated, Reason, Child, State#state.name), restart(Child, State); -do_restart(temporary, Reason, Child, State) -> - report_error(child_terminated, Reason, Child, State#state.name), - NState = state_del_child(Child, State), +do_restart(Reason, Child, State) when ?is_temporary(Child) -> + ?report_error(child_terminated, Reason, Child, State#state.name), + NState = del_child(Child, State), {ok, NState}. restart(Child, State) -> case add_restart(State) of {ok, NState} -> case restart(NState#state.strategy, Child, NState) of - {try_again,NState2} -> + {{try_again, TryAgainId}, NState2} -> %% Leaving control back to gen_server before %% trying again. This way other incoming requsts %% for the supervisor can be handled - e.g. a %% shutdown request for the supervisor or the %% child. - 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,NState2}; - {try_again, NState2, #child{name=ChName}} -> - {ok, _TRef} = timer:apply_after(0, - ?MODULE, - try_again_restart, - [self(),ChName]), + try_again_restart(TryAgainId), {ok,NState2}; Other -> Other end; {terminate, NState} -> - report_error(shutdown, reached_max_restart_intensity, + ?report_error(shutdown, reached_max_restart_intensity, Child, State#state.name), - {shutdown, remove_child(Child, NState)} + {shutdown, del_child(Child, NState)} end. restart(simple_one_for_one, Child, State0) -> #child{pid = OldPid, mfargs = {M, F, A}} = Child, - State = case OldPid of + State1 = 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)), + State2 = dyn_erase(OldPid, State1), case do_start_child_i(M, F, A) of {ok, Pid} -> - NState = State#state{dynamics = ?DICTS:store(Pid, A, Dynamics)}, + NState = dyn_store(Pid, A, State2), {ok, NState}; {ok, Pid, _Extra} -> - NState = State#state{dynamics = ?DICTS:store(Pid, A, Dynamics)}, + NState = dyn_store(Pid, A, State2), {ok, NState}; {error, Error} -> - NRestarts = State#state.dynamic_restarts + 1, - NState = State#state{dynamic_restarts = NRestarts, - dynamics = ?DICTS:store(restarting(OldPid), A, - Dynamics)}, - report_error(start_error, Error, Child, State#state.name), - {try_again, NState} + ROldPid = restarting(OldPid), + NRestarts = State2#state.dynamic_restarts + 1, + State3 = State2#state{dynamic_restarts = NRestarts}, + NState = dyn_store(ROldPid, A, State3), + ?report_error(start_error, Error, Child, NState#state.name), + {{try_again, ROldPid}, NState} end; -restart(one_for_one, Child, State) -> +restart(one_for_one, #child{id=Id} = Child, State) -> OldPid = Child#child.pid, case do_start_child(State#state.name, Child) of {ok, Pid} -> - NState = replace_child(Child#child{pid = Pid}, State), + NState = set_pid(Pid, Id, State), {ok, NState}; {ok, Pid, _Extra} -> - NState = replace_child(Child#child{pid = Pid}, State), + NState = set_pid(Pid, Id, State), {ok, NState}; {error, Reason} -> - NState = replace_child(Child#child{pid = restarting(OldPid)}, State), - report_error(start_error, Reason, Child, State#state.name), - {try_again, NState} + NState = set_pid(restarting(OldPid), Id, State), + ?report_error(start_error, Reason, Child, State#state.name), + {{try_again,Id}, NState} end; -restart(rest_for_one, Child, State) -> - {ChAfter, ChBefore} = split_child(Child#child.pid, State#state.children), - ChAfter2 = terminate_children(ChAfter, State#state.name), - case start_children(ChAfter2, State#state.name) of - {ok, ChAfter3} -> - {ok, State#state{children = ChAfter3 ++ ChBefore}}; - {error, ChAfter3, {failed_to_start_child, ChName, _Reason}} - when ChName =:= Child#child.name -> - NChild = Child#child{pid=restarting(Child#child.pid)}, - NState = State#state{children = ChAfter3 ++ ChBefore}, - {try_again, replace_child(NChild,NState)}; - {error, ChAfter3, {failed_to_start_child, ChName, _Reason}} -> - NChild = lists:keyfind(ChName, #child.name, ChAfter3), - NChild2 = NChild#child{pid=?restarting(undefined)}, - NState = State#state{children = ChAfter3 ++ ChBefore}, - {try_again, replace_child(NChild2,NState), NChild2} - end; -restart(one_for_all, Child, State) -> - Children1 = del_child(Child#child.pid, State#state.children), - Children2 = terminate_children(Children1, State#state.name), - case start_children(Children2, State#state.name) of - {ok, NChs} -> - {ok, State#state{children = NChs}}; - {error, NChs, {failed_to_start_child, ChName, _Reason}} - when ChName =:= Child#child.name -> - NChild = Child#child{pid=restarting(Child#child.pid)}, - NState = State#state{children = NChs}, - {try_again, replace_child(NChild,NState)}; - {error, NChs, {failed_to_start_child, ChName, _Reason}} -> - NChild = lists:keyfind(ChName, #child.name, NChs), - NChild2 = NChild#child{pid=?restarting(undefined)}, - NState = State#state{children = NChs}, - {try_again, replace_child(NChild2,NState), NChild2} +restart(rest_for_one, #child{id=Id} = Child, #state{name=SupName} = State) -> + {ChAfter, ChBefore} = split_child(Id, State#state.children), + {Return, ChAfter2} = restart_multiple_children(Child, ChAfter, SupName), + {Return, State#state{children = append(ChAfter2,ChBefore)}}; +restart(one_for_all, Child, #state{name=SupName} = State) -> + Children1 = del_child(Child#child.id, State#state.children), + {Return, NChildren} = restart_multiple_children(Child, Children1, SupName), + {Return, State#state{children = NChildren}}. + +restart_multiple_children(Child, Children, SupName) -> + Children1 = terminate_children(Children, SupName), + case start_children(Children1, SupName) of + {ok, NChildren} -> + {ok, NChildren}; + {error, NChildren, {failed_to_start_child, FailedId, _Reason}} -> + NewPid = if FailedId =:= Child#child.id -> + restarting(Child#child.pid); + true -> + ?restarting(undefined) + end, + {{try_again, FailedId}, set_pid(NewPid,FailedId,NChildren)} end. restarting(Pid) when is_pid(Pid) -> ?restarting(Pid); restarting(RPid) -> RPid. +-spec try_again_restart(child_id() | {'restarting',pid()}) -> 'ok'. +try_again_restart(TryAgainId) -> + gen_server:cast(self(), {try_again_restart, TryAgainId}). + %%----------------------------------------------------------------- %% Func: terminate_children/2 -%% Args: Children = [child_rec()] in termination order +%% Args: Children = children() % Ids in termination order %% SupName = {local, atom()} | {global, atom()} | {pid(),Mod} -%% Returns: NChildren = [child_rec()] in -%% startup order (reversed termination order) +%% Returns: NChildren = children() % Ids in startup order +%% % (reversed termination order) %%----------------------------------------------------------------- terminate_children(Children, SupName) -> - terminate_children(Children, SupName, []). - -%% Temporary children should not be restarted and thus should -%% be skipped when building the list of terminated children, although -%% we do want them to be shut down as many functions from this module -%% use this function to just clear everything. -terminate_children([Child = #child{restart_type=temporary} | Children], SupName, Res) -> - _ = do_terminate(Child, SupName), - terminate_children(Children, SupName, Res); -terminate_children([Child | Children], SupName, Res) -> - NChild = do_terminate(Child, SupName), - terminate_children(Children, SupName, [NChild | Res]); -terminate_children([], _SupName, Res) -> - Res. + Terminate = + fun(_Id,Child) when ?is_temporary(Child) -> + %% Temporary children should not be restarted and thus should + %% be skipped when building the list of terminated children. + do_terminate(Child, SupName), + remove; + (_Id,Child) -> + do_terminate(Child, SupName), + {update,Child#child{pid=undefined}} + end, + {ok,NChildren} = children_map(Terminate, Children), + NChildren. do_terminate(Child, SupName) when is_pid(Child#child.pid) -> case shutdown(Child#child.pid, Child#child.shutdown) of ok -> ok; - {error, normal} when Child#child.restart_type =/= permanent -> + {error, normal} when not (?is_permanent(Child)) -> ok; {error, OtherReason} -> - report_error(shutdown_error, OtherReason, Child, SupName) + ?report_error(shutdown_error, OtherReason, Child, SupName) end, - Child#child{pid = undefined}; -do_terminate(Child, _SupName) -> - Child#child{pid = undefined}. + ok; +do_terminate(_Child, _SupName) -> + ok. %%----------------------------------------------------------------- %% Shutdowns a child. We must check the EXIT value @@ -993,66 +912,50 @@ monitor_child(Pid) -> ok end. - %%----------------------------------------------------------------- -%% Func: terminate_dynamic_children/3 -%% Args: Child = child_rec() -%% Dynamics = ?DICT() | ?SET() -%% SupName = {local, atom()} | {global, atom()} | {pid(),Mod} +%% Func: terminate_dynamic_children/1 +%% Args: State %% Returns: ok %% -%% %% Shutdown all dynamic children. This happens when the supervisor is %% stopped. Because the supervisor can have millions of dynamic children, we -%% can have an significative overhead here. +%% can have a significative overhead here. %%----------------------------------------------------------------- -terminate_dynamic_children(Child, Dynamics, SupName) -> - {Pids, EStack0} = monitor_dynamic_children(Child, Dynamics), - Sz = ?SETS:size(Pids), +terminate_dynamic_children(State) -> + Child = get_dynamic_child(State), + {Pids, EStack0} = monitor_dynamic_children(Child,State), + Sz = sets:size(Pids), EStack = case Child#child.shutdown of brutal_kill -> - ?SETS:fold(fun(P, _) -> exit(P, kill) end, ok, Pids), + sets:fold(fun(P, _) -> exit(P, kill) end, ok, Pids), wait_dynamic_children(Child, Pids, Sz, undefined, EStack0); infinity -> - ?SETS:fold(fun(P, _) -> exit(P, shutdown) end, ok, Pids), + sets:fold(fun(P, _) -> exit(P, shutdown) end, ok, Pids), wait_dynamic_children(Child, Pids, Sz, undefined, EStack0); Time -> - ?SETS:fold(fun(P, _) -> exit(P, shutdown) end, ok, Pids), + sets:fold(fun(P, _) -> exit(P, shutdown) end, ok, Pids), TRef = erlang:start_timer(Time, self(), kill), wait_dynamic_children(Child, Pids, Sz, TRef, EStack0) end, %% Unroll stacked errors and report them - ?DICTS:fold(fun(Reason, Ls, _) -> - report_error(shutdown_error, Reason, - Child#child{pid=Ls}, SupName) - end, ok, EStack). - - -monitor_dynamic_children(#child{restart_type=temporary}, Dynamics) -> - ?SETS:fold(fun(P, {Pids, EStack}) -> - case monitor_child(P) of - ok -> - {?SETS:add_element(P, Pids), EStack}; - {error, normal} -> - {Pids, EStack}; - {error, Reason} -> - {Pids, ?DICTS:append(Reason, P, EStack)} - end - end, {?SETS:new(), ?DICTS:new()}, Dynamics); -monitor_dynamic_children(#child{restart_type=RType}, Dynamics) -> - ?DICTS:fold(fun(P, _, {Pids, EStack}) when is_pid(P) -> - case monitor_child(P) of - ok -> - {?SETS:add_element(P, Pids), EStack}; - {error, normal} when RType =/= permanent -> - {Pids, EStack}; - {error, Reason} -> - {Pids, ?DICTS:append(Reason, P, EStack)} - end; - (?restarting(_), _, {Pids, EStack}) -> - {Pids, EStack} - end, {?SETS:new(), ?DICTS:new()}, Dynamics). - + dict:fold(fun(Reason, Ls, _) -> + ?report_error(shutdown_error, Reason, + Child#child{pid=Ls}, State#state.name) + end, ok, EStack). + +monitor_dynamic_children(Child,State) -> + dyn_fold(fun(P,{Pids, EStack}) when is_pid(P) -> + case monitor_child(P) of + ok -> + {sets:add_element(P, Pids), EStack}; + {error, normal} when not (?is_permanent(Child)) -> + {Pids, EStack}; + {error, Reason} -> + {Pids, dict:append(Reason, P, EStack)} + end; + (?restarting(_), {Pids, EStack}) -> + {Pids, EStack} + end, {sets:new(), dict:new()}, State). wait_dynamic_children(_Child, _Pids, 0, undefined, EStack) -> EStack; @@ -1070,35 +973,38 @@ wait_dynamic_children(#child{shutdown=brutal_kill} = Child, Pids, Sz, TRef, EStack) -> receive {'DOWN', _MRef, process, Pid, killed} -> - wait_dynamic_children(Child, ?SETS:del_element(Pid, Pids), Sz-1, + wait_dynamic_children(Child, sets:del_element(Pid, Pids), Sz-1, TRef, EStack); {'DOWN', _MRef, process, Pid, Reason} -> - wait_dynamic_children(Child, ?SETS:del_element(Pid, Pids), Sz-1, - TRef, ?DICTS:append(Reason, Pid, EStack)) + wait_dynamic_children(Child, sets:del_element(Pid, Pids), Sz-1, + TRef, dict:append(Reason, Pid, EStack)) end; -wait_dynamic_children(#child{restart_type=RType} = Child, Pids, Sz, - TRef, EStack) -> +wait_dynamic_children(Child, Pids, Sz, TRef, EStack) -> receive {'DOWN', _MRef, process, Pid, shutdown} -> - wait_dynamic_children(Child, ?SETS:del_element(Pid, Pids), Sz-1, + 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, + {'DOWN', _MRef, process, Pid, {shutdown, _}} -> + wait_dynamic_children(Child, sets:del_element(Pid, Pids), Sz-1, + TRef, EStack); + + {'DOWN', _MRef, process, Pid, normal} when not (?is_permanent(Child)) -> + wait_dynamic_children(Child, sets:del_element(Pid, Pids), Sz-1, TRef, EStack); {'DOWN', _MRef, process, Pid, Reason} -> - wait_dynamic_children(Child, ?SETS:del_element(Pid, Pids), Sz-1, - TRef, ?DICTS:append(Reason, Pid, EStack)); + wait_dynamic_children(Child, sets:del_element(Pid, Pids), Sz-1, + TRef, dict:append(Reason, Pid, EStack)); {timeout, TRef, kill} -> - ?SETS:fold(fun(P, _) -> exit(P, kill) end, ok, Pids), + sets:fold(fun(P, _) -> exit(P, kill) end, ok, Pids), wait_dynamic_children(Child, Pids, Sz, undefined, EStack) end. %%----------------------------------------------------------------- -%% Child/State manipulating functions. +%% Access #state.children %%----------------------------------------------------------------- %% Note we do not want to save the parameter list for temporary processes as @@ -1106,114 +1012,184 @@ wait_dynamic_children(#child{restart_type=RType} = Child, Pids, Sz, %% Especially for dynamic children to simple_one_for_one supervisors %% it could become very costly as it is not uncommon to spawn %% very many such processes. -save_child(#child{restart_type = temporary, - mfargs = {M, F, _}} = Child, #state{children = Children} = State) -> - State#state{children = [Child#child{mfargs = {M, F, undefined}} |Children]}; -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))}; -save_dynamic_child(RestartType, Pid, Args, #state{dynamics = Dynamics} = State) -> - State#state{dynamics = ?DICTS:store(Pid, Args, dynamics_db(RestartType, Dynamics))}. - -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) +-spec save_child(child_rec(), state()) -> state(). +save_child(#child{mfargs = {M, F, _}} = Child, State) when ?is_temporary(Child) -> + do_save_child(Child#child{mfargs = {M, F, undefined}}, State); +save_child(Child, State) -> + do_save_child(Child, State). + +-spec do_save_child(child_rec(), state()) -> state(). +do_save_child(#child{id = Id} = Child, #state{children = {Ids,Db}} = State) -> + State#state{children = {[Id|Ids],Db#{Id => Child}}}. + +-spec del_child(child_rec(), state()) -> state(); + (child_id(), children()) -> children(). +del_child(#child{pid = Pid}, State) when ?is_simple(State) -> + dyn_erase(Pid,State); +del_child(Child, State) when is_record(Child,child), is_record(State,state) -> + NChildren = del_child(Child#child.id, State#state.children), + State#state{children = NChildren}; +del_child(Id, {Ids,Db}) -> + case maps:get(Id, Db) of + Child when Child#child.restart_type =:= temporary -> + {lists:delete(Id, Ids), maps:remove(Id, Db)}; + Child -> + {Ids, Db#{Id=>Child#child{pid=undefined}}} end. -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_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_del_child(Child, State) -> - NChildren = del_child(Child#child.name, State#state.children), - State#state{children = NChildren}. - -del_child(Name, [Ch|Chs]) when Ch#child.name =:= Name, Ch#child.restart_type =:= temporary -> - Chs; -del_child(Name, [Ch|Chs]) when Ch#child.name =:= Name -> - [Ch#child{pid = undefined} | Chs]; -del_child(Pid, [Ch|Chs]) when Ch#child.pid =:= Pid, Ch#child.restart_type =:= temporary -> - Chs; -del_child(Pid, [Ch|Chs]) when Ch#child.pid =:= Pid -> - [Ch#child{pid = undefined} | Chs]; -del_child(Name, [Ch|Chs]) -> - [Ch|del_child(Name, Chs)]; -del_child(_, []) -> - []. - -%% Chs = [S4, S3, Ch, S1, S0] -%% Ret: {[S4, S3, Ch], [S1, S0]} -split_child(Name, Chs) -> - split_child(Name, Chs, []). - -split_child(Name, [Ch|Chs], After) when Ch#child.name =:= Name -> - {lists:reverse([Ch#child{pid = undefined} | After]), Chs}; -split_child(Pid, [Ch|Chs], After) when Ch#child.pid =:= Pid -> - {lists:reverse([Ch#child{pid = undefined} | After]), Chs}; -split_child(Name, [Ch|Chs], After) -> - split_child(Name, Chs, [Ch | After]); -split_child(_, [], After) -> - {lists:reverse(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 - true -> - {value, Child#child{pid=Pid}}; - false -> - RPid = restarting(Pid), - case is_dynamic_pid(RPid, DynamicsDb) of - true -> - {value, Child#child{pid=RPid}}; - false -> +%% In: {[S4, S3, Ch, S1, S0],Db} +%% Ret: {{[S4, S3, Ch],Db1}, {[S1, S0],Db2}} +%% Db1 and Db2 contain the keys in the lists they are associated with. +-spec split_child(child_id(), children()) -> {children(), children()}. +split_child(Id, {Ids,Db}) -> + {IdsAfter,IdsBefore} = split_ids(Id, Ids, []), + DbBefore = maps:with(IdsBefore,Db), + #{Id:=Ch} = DbAfter = maps:with(IdsAfter,Db), + {{IdsAfter,DbAfter#{Id=>Ch#child{pid=undefined}}},{IdsBefore,DbBefore}}. + +split_ids(Id, [Id|Ids], After) -> + {lists:reverse([Id|After]), Ids}; +split_ids(Id, [Other|Ids], After) -> + split_ids(Id, Ids, [Other | After]). + +%% Find the child record for a given Pid (dynamic child) or Id +%% (non-dynamic child). This is called from the API functions. +-spec find_child(pid() | child_id(), state()) -> {ok,child_rec()} | error. +find_child(Pid, State) when is_pid(Pid), ?is_simple(State) -> + case find_dynamic_child(Pid, State) of + error -> + case find_dynamic_child(restarting(Pid), State) of + error -> case erlang:is_process_alive(Pid) of - true -> false; - false -> {value, Child} - end - end + true -> error; + false -> {ok, get_dynamic_child(State)} + end; + Other -> + Other + end; + Other -> + Other + end; +find_child(Id, #state{children = {_Ids,Db}}) -> + maps:find(Id, Db). + +%% Get the child record - either by child id or by pid. If +%% simple_one_for_one, then insert the pid and args into the returned +%% child record. This is called when trying to restart the child. +-spec find_child_and_args(IdOrPid, state()) -> {ok, child_rec()} | error when + IdOrPid :: pid() | {restarting,pid()} | child_id(). +find_child_and_args(Pid, State) when ?is_simple(State) -> + case find_dynamic_child(Pid, State) of + {ok,#child{mfargs={M,F,_}} = Child} -> + {ok, Args} = dyn_args(Pid, State), + {ok, Child#child{mfargs = {M, F, Args}}}; + error -> + error + end; +find_child_and_args(Pid, State) when is_pid(Pid) -> + find_child_by_pid(Pid, State); +find_child_and_args(Id, #state{children={_Ids,Db}}) -> + maps:find(Id, Db). + +%% Given the pid, find the child record for a dynamic child, and +%% include the pid in the returned record. +-spec find_dynamic_child(IdOrPid, state()) -> {ok, child_rec()} | error when + IdOrPid :: pid() | {restarting,pid()} | child_id(). +find_dynamic_child(Pid, State) -> + case dyn_exists(Pid, State) of + true -> + Child = get_dynamic_child(State), + {ok, Child#child{pid=Pid}}; + false -> + error end. -is_dynamic_pid(Pid, Dynamics) -> - case ?SETS:is_set(Dynamics) of - true -> - ?SETS:is_element(Pid, Dynamics); - false -> - ?DICTS:is_key(Pid, Dynamics) +%% Given the pid, find the child record for a non-dyanamic child. +-spec find_child_by_pid(IdOrPid, state()) -> {ok,child_rec()} | error when + IdOrPid :: pid() | {restarting,pid()}. +find_child_by_pid(Pid,#state{children={_Ids,Db}}) -> + Fun = fun(_Id,#child{pid=P}=Ch,_) when P =:= Pid -> + throw(Ch); + (_,_,error) -> + error + end, + try maps:fold(Fun,error,Db) + catch throw:Child -> {ok,Child} end. -replace_child(Child, State) -> - Chs = do_replace_child(Child, State#state.children), - State#state{children = Chs}. - -do_replace_child(Child, [Ch|Chs]) when Ch#child.name =:= Child#child.name -> - [Child | Chs]; -do_replace_child(Child, [Ch|Chs]) -> - [Ch|do_replace_child(Child, Chs)]. - -remove_child(Child, State) -> - Chs = lists:keydelete(Child#child.name, #child.name, State#state.children), - State#state{children = Chs}. +%% Get the child record from a simple_one_for_one supervisor - no pid +%% It is assumed that the child can always be found +-spec get_dynamic_child(state()) -> child_rec(). +get_dynamic_child(#state{children={[Id],Db}}) -> + #{Id := Child} = Db, + Child. + +%% Update pid in the given child record and store it in the process state +-spec set_pid(term(), child_id(), state()) -> state(); + (term(), child_id(), children()) -> children(). +set_pid(Pid, Id, #state{children=Children} = State) -> + State#state{children = set_pid(Pid, Id, Children)}; +set_pid(Pid, Id, {Ids, Db}) -> + NewDb = maps:update_with(Id, fun(Child) -> Child#child{pid=Pid} end, Db), + {Ids,NewDb}. + +%% Remove the Id and the child record from the process state +-spec remove_child(child_id(), state()) -> state(). +remove_child(Id, #state{children={Ids,Db}} = State) -> + NewIds = lists:delete(Id,Ids), + NewDb = maps:remove(Id,Db), + State#state{children = {NewIds,NewDb}}. + +%% In the order of Ids, traverse the children and update each child +%% according to the return value of the Fun. +%% On error, abort and return the merge of the old and the updated map. +%% NOTE: The returned list of Ids is reverted compared to the input. +-spec children_map(Fun, children()) -> {ok, children()} | + {error,children(),Reason} when + Fun :: fun((child_id(),child_rec()) -> {update,child_rec()} | + remove | + {abort, Reason}), + Reason :: term(). +children_map(Fun,{Ids,Db}) -> + children_map(Fun, Ids, Db, []). + +children_map(Fun,[Id|Ids],Db,Acc) -> + case Fun(Id,maps:get(Id,Db)) of + {update,Child} -> + children_map(Fun,Ids,Db#{Id => Child},[Id|Acc]); + remove -> + children_map(Fun,Ids,maps:remove(Id,Db),Acc); + {abort,Reason} -> + {error,{lists:reverse(Ids)++[Id|Acc],Db},Reason} + end; +children_map(_Fun,[],Db,Acc) -> + {ok,{Acc,Db}}. + +%% In the order of Ids, map over all children and return the list +-spec children_to_list(Fun, children()) -> List when + Fun :: fun((child_id(), child_rec()) -> Elem), + List :: list(Elem), + Elem :: term(). +children_to_list(Fun,{Ids,Db}) -> + children_to_list(Fun, Ids, Db, []). +children_to_list(Fun,[Id|Ids],Db,Acc) -> + children_to_list(Fun,Ids,Db,[Fun(Id,maps:get(Id,Db))|Acc]); +children_to_list(_Fun,[],_Db,Acc) -> + lists:reverse(Acc). + +%% The order is not important - so ignore Ids +-spec children_fold(Fun, Acc0, children()) -> Acc1 when + Fun :: fun((child_id(), child_rec(), AccIn) -> AccOut), + Acc0 :: term(), + Acc1 :: term(), + AccIn :: term(), + AccOut :: term(). +children_fold(Fun,Init,{_Ids,Db}) -> + maps:fold(Fun, Init, Db). + +-spec append(children(), children()) -> children(). +append({Ids1,Db1},{Ids2,Db2}) -> + {Ids1++Ids2,maps:merge(Db1,Db2)}. %%----------------------------------------------------------------- %% Func: init_state/4 @@ -1283,27 +1259,27 @@ supname(N, _) -> N. %%% Returns: {ok, [child_rec()]} | Error %%% ------------------------------------------------------ -check_startspec(Children) -> check_startspec(Children, []). +check_startspec(Children) -> check_startspec(Children, [], #{}). -check_startspec([ChildSpec|T], Res) -> +check_startspec([ChildSpec|T], Ids, Db) -> case check_childspec(ChildSpec) of - {ok, Child} -> - case lists:keymember(Child#child.name, #child.name, Res) of + {ok, #child{id=Id}=Child} -> + case maps:is_key(Id, Db) of %% The error message duplicate_child_name is kept for %% backwards compatibility, although %% duplicate_child_id would be more correct. - true -> {duplicate_child_name, Child#child.name}; - false -> check_startspec(T, [Child | Res]) + true -> {duplicate_child_name, Id}; + false -> check_startspec(T, [Id | Ids], Db#{Id=>Child}) end; Error -> Error end; -check_startspec([], Res) -> - {ok, lists:reverse(Res)}. +check_startspec([], Ids, Db) -> + {ok, {lists:reverse(Ids),Db}}. check_childspec(ChildSpec) when is_map(ChildSpec) -> catch do_check_childspec(maps:merge(?default_child_spec,ChildSpec)); -check_childspec({Name, Func, RestartType, Shutdown, ChildType, Mods}) -> - check_childspec(#{id => Name, +check_childspec({Id, Func, RestartType, Shutdown, ChildType, Mods}) -> + check_childspec(#{id => Id, start => Func, restart => RestartType, shutdown => Shutdown, @@ -1313,15 +1289,15 @@ check_childspec(X) -> {invalid_child_spec, X}. do_check_childspec(#{restart := RestartType, type := ChildType} = ChildSpec)-> - Name = case ChildSpec of - #{id := N} -> N; + Id = case ChildSpec of + #{id := I} -> I; _ -> throw(missing_id) end, Func = case ChildSpec of #{start := F} -> F; _ -> throw(missing_start) end, - validName(Name), + validId(Id), validFunc(Func), validRestartType(RestartType), validChildType(ChildType), @@ -1336,14 +1312,14 @@ do_check_childspec(#{restart := RestartType, _ -> {M,_,_} = Func, [M] end, validMods(Mods), - {ok, #child{name = Name, mfargs = Func, restart_type = RestartType, + {ok, #child{id = Id, mfargs = Func, restart_type = RestartType, shutdown = Shutdown, child_type = ChildType, modules = Mods}}. validChildType(supervisor) -> true; validChildType(worker) -> true; validChildType(What) -> throw({invalid_child_type, What}). -validName(_Name) -> true. +validId(_Id) -> true. validFunc({M, F, A}) when is_atom(M), is_atom(F), @@ -1372,13 +1348,13 @@ validMods(Mods) when is_list(Mods) -> Mods); validMods(Mods) -> throw({invalid_modules, Mods}). -child_to_spec(#child{name = Name, +child_to_spec(#child{id = Id, mfargs = Func, restart_type = RestartType, shutdown = Shutdown, child_type = ChildType, modules = Mods}) -> - #{id => Name, + #{id => Id, start => Func, restart => RestartType, shutdown => Shutdown, @@ -1424,31 +1400,75 @@ inPeriod(Then, Now, Period) -> %%% ------------------------------------------------------ %%% Error and progress reporting. %%% ------------------------------------------------------ - -report_error(Error, Reason, Child, SupName) -> - ErrorMsg = [{supervisor, SupName}, - {errorContext, Error}, - {reason, Reason}, - {offender, extract_child(Child)}], - error_logger:error_report(supervisor_report, ErrorMsg). - - extract_child(Child) when is_list(Child#child.pid) -> [{nb_children, length(Child#child.pid)}, - {id, Child#child.name}, + {id, Child#child.id}, {mfargs, Child#child.mfargs}, {restart_type, Child#child.restart_type}, {shutdown, Child#child.shutdown}, {child_type, Child#child.child_type}]; extract_child(Child) -> [{pid, Child#child.pid}, - {id, Child#child.name}, + {id, Child#child.id}, {mfargs, Child#child.mfargs}, {restart_type, Child#child.restart_type}, {shutdown, Child#child.shutdown}, {child_type, Child#child.child_type}]. report_progress(Child, SupName) -> - Progress = [{supervisor, SupName}, - {started, extract_child(Child)}], - error_logger:info_report(progress, Progress). + ?LOG_INFO(#{label=>{supervisor,progress}, + report=>[{supervisor,SupName}, + {started,extract_child(Child)}]}, + #{domain=>[otp,sasl], + report_cb=>fun logger:format_otp_report/1, + logger_formatter=>#{title=>"PROGRESS REPORT"}, + error_logger=>#{tag=>info_report,type=>progress}}). + +format_status(terminate, [_PDict, State]) -> + State; +format_status(_, [_PDict, State]) -> + [{data, [{"State", State}]}, + {supervisor, [{"Callback", State#state.module}]}]. + +%%%----------------------------------------------------------------- +%%% Dynamics database access +dyn_size(#state{dynamics = {Mod,Db}}) -> + Mod:size(Db). + +dyn_erase(Pid,#state{dynamics={sets,Db}}=State) -> + State#state{dynamics={sets,sets:del_element(Pid,Db)}}; +dyn_erase(Pid,#state{dynamics={maps,Db}}=State) -> + State#state{dynamics={maps,maps:remove(Pid,Db)}}. + +dyn_store(Pid,_,#state{dynamics={sets,Db}}=State) -> + State#state{dynamics={sets,sets:add_element(Pid,Db)}}; +dyn_store(Pid,Args,#state{dynamics={maps,Db}}=State) -> + State#state{dynamics={maps,Db#{Pid => Args}}}. + +dyn_fold(Fun,Init,#state{dynamics={sets,Db}}) -> + sets:fold(Fun,Init,Db); +dyn_fold(Fun,Init,#state{dynamics={maps,Db}}) -> + maps:fold(fun(Pid,_,Acc) -> Fun(Pid,Acc) end, Init, Db). + +dyn_map(Fun, #state{dynamics={sets,Db}}) -> + lists:map(Fun, sets:to_list(Db)); +dyn_map(Fun, #state{dynamics={maps,Db}}) -> + lists:map(Fun, maps:keys(Db)). + +dyn_exists(Pid, #state{dynamics={sets, Db}}) -> + sets:is_element(Pid, Db); +dyn_exists(Pid, #state{dynamics={maps, Db}}) -> + maps:is_key(Pid, Db). + +dyn_args(_Pid, #state{dynamics={sets, _Db}}) -> + {ok,undefined}; +dyn_args(Pid, #state{dynamics={maps, Db}}) -> + maps:find(Pid, Db). + +dyn_init(State) -> + dyn_init(get_dynamic_child(State),State). + +dyn_init(Child,State) when ?is_temporary(Child) -> + State#state{dynamics={sets,sets:new()}}; +dyn_init(_Child,State) -> + State#state{dynamics={maps,maps:new()}}. diff --git a/lib/stdlib/src/supervisor_bridge.erl b/lib/stdlib/src/supervisor_bridge.erl index 18218b71ad..21ba6f53af 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-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. @@ -21,6 +21,8 @@ -behaviour(gen_server). +-include("logger.hrl"). + %% External exports -export([start_link/2, start_link/3]). %% Internal exports @@ -129,13 +131,22 @@ terminate_pid(Reason, #state{mod = Mod, child_state = ChildState}) -> Mod:terminate(Reason, ChildState). report_progress(Pid, Mod, StartArgs, SupName) -> - Progress = [{supervisor, SupName}, - {started, [{pid, Pid}, {mfa, {Mod, init, [StartArgs]}}]}], - error_logger:info_report(progress, Progress). + ?LOG_INFO(#{label=>{supervisor,progress}, + report=>[{supervisor, SupName}, + {started, [{pid, Pid}, + {mfa, {Mod, init, [StartArgs]}}]}]}, + #{domain=>[otp,sasl], + report_cb=>fun logger:format_otp_report/1, + logger_formatter=>#{title=>"PROGRESS REPORT"}, + error_logger=>#{tag=>info_report,type=>progress}}). report_error(Error, Reason, #state{name = Name, pid = Pid, mod = Mod}) -> - ErrorMsg = [{supervisor, Name}, - {errorContext, Error}, - {reason, Reason}, - {offender, [{pid, Pid}, {mod, Mod}]}], - error_logger:error_report(supervisor_report, ErrorMsg). + ?LOG_ERROR(#{label=>{supervisor,error}, + report=>[{supervisor, Name}, + {errorContext, Error}, + {reason, Reason}, + {offender, [{pid, Pid}, {mod, Mod}]}]}, + #{domain=>[otp,sasl], + report_cb=>fun logger:format_otp_report/1, + logger_formatter=>#{title=>"SUPERVISOR REPORT"}, + error_logger=>#{tag=>error_report,type=>supervisor_report}}). diff --git a/lib/stdlib/src/sys.erl b/lib/stdlib/src/sys.erl index a7debb00f5..0064414d6f 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,10 +38,13 @@ -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 :: _} + | {'out', Msg :: _, To :: _, State :: _} | term(). -opaque dbg_opt() :: {'trace', 'true'} | {'log', @@ -54,7 +57,8 @@ MessagesIn :: non_neg_integer(), MessagesOut :: non_neg_integer()}} | {'log_to_file', file:io_device()} - | {Func :: dbg_fun(), FuncState :: term()}. + | {Func :: dbg_fun(), FuncState :: term()} + | {FuncId :: term(), Func :: dbg_fun(), FuncState :: term()}. -type dbg_fun() :: fun((FuncState :: _, Event :: system_event(), ProcState :: _) -> 'done' | (NewFuncState :: _)). @@ -265,33 +269,41 @@ no_debug(Name, Timeout) -> send_system_msg(Name, {debug, no_debug}, Timeout). -spec install(Name, FuncSpec) -> 'ok' when Name :: name(), - FuncSpec :: {Func, FuncState}, + FuncSpec :: {Func, FuncState} | {FuncId, Func, FuncState}, + FuncId :: term(), Func :: dbg_fun(), FuncState :: term(). install(Name, {Func, FuncState}) -> - send_system_msg(Name, {debug, {install, {Func, FuncState}}}). + send_system_msg(Name, {debug, {install, {Func, FuncState}}}); +install(Name, {FuncId, Func, FuncState}) -> + send_system_msg(Name, {debug, {install, {FuncId, Func, FuncState}}}). -spec install(Name, FuncSpec, Timeout) -> 'ok' when Name :: name(), - FuncSpec :: {Func, FuncState}, + FuncSpec :: {Func, FuncState} | {FuncId, Func, FuncState}, + FuncId :: term(), Func :: dbg_fun(), FuncState :: term(), Timeout :: timeout(). install(Name, {Func, FuncState}, Timeout) -> - send_system_msg(Name, {debug, {install, {Func, FuncState}}}, Timeout). + send_system_msg(Name, {debug, {install, {Func, FuncState}}}, Timeout); +install(Name, {FuncId, Func, FuncState}, Timeout) -> + send_system_msg(Name, {debug, {install, {FuncId, Func, FuncState}}}, Timeout). --spec remove(Name, Func) -> 'ok' when +-spec remove(Name, Func | FuncId) -> 'ok' when Name :: name(), - Func :: dbg_fun(). -remove(Name, Func) -> - send_system_msg(Name, {debug, {remove, Func}}). + Func :: dbg_fun(), + FuncId :: term(). +remove(Name, FuncOrFuncId) -> + send_system_msg(Name, {debug, {remove, FuncOrFuncId}}). --spec remove(Name, Func, Timeout) -> 'ok' when +-spec remove(Name, Func | FuncId, Timeout) -> 'ok' when Name :: name(), Func :: dbg_fun(), + FuncId :: term(), Timeout :: timeout(). -remove(Name, Func, Timeout) -> - send_system_msg(Name, {debug, {remove, Func}}, Timeout). +remove(Name, FuncOrFuncId, Timeout) -> + send_system_msg(Name, {debug, {remove, FuncOrFuncId}}, Timeout). %%----------------------------------------------------------------- %% All system messages sent are on the form {system, From, Msg} @@ -385,6 +397,13 @@ handle_debug([{log_to_file, Fd} | T], FormFunc, State, Event) -> handle_debug([{statistics, StatData} | T], FormFunc, State, Event) -> NStatData = stat(Event, StatData), [{statistics, NStatData} | handle_debug(T, FormFunc, State, Event)]; +handle_debug([{FuncId, {Func, FuncState}} | T], FormFunc, State, Event) -> + case catch Func(FuncState, Event, State) of + done -> handle_debug(T, FormFunc, State, Event); + {'EXIT', _} -> handle_debug(T, FormFunc, State, Event); + NFuncState -> + [{FuncId, {Func, NFuncState}} | handle_debug(T, FormFunc, State, Event)] + end; handle_debug([{Func, FuncState} | T], FormFunc, State, Event) -> case catch Func(FuncState, Event, State) of done -> handle_debug(T, FormFunc, State, Event); @@ -525,7 +544,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 -> @@ -542,8 +561,10 @@ debug_cmd(no_debug, Debug) -> {ok, []}; debug_cmd({install, {Func, FuncState}}, Debug) -> {ok, install_debug(Func, FuncState, Debug)}; -debug_cmd({remove, Func}, Debug) -> - {ok, remove_debug(Func, Debug)}; +debug_cmd({install, {FuncId, Func, FuncState}}, Debug) -> + {ok, install_debug(FuncId, {Func, FuncState}, Debug)}; +debug_cmd({remove, FuncOrFuncId}, Debug) -> + {ok, remove_debug(FuncOrFuncId, Debug)}; debug_cmd(_Unknown, Debug) -> {unknown_debug, Debug}. @@ -571,6 +592,7 @@ get_stat(_) -> stat({in, _Msg}, {Time, Reds, In, Out}) -> {Time, Reds, In+1, Out}; stat({in, _Msg, _From}, {Time, Reds, In, Out}) -> {Time, Reds, In+1, Out}; stat({out, _Msg, _To}, {Time, Reds, In, Out}) -> {Time, Reds, In, Out+1}; +stat({out, _Msg, _To, _State}, {Time, Reds, In, Out}) -> {Time, Reds, In, Out+1}; stat(_, StatData) -> StatData. trim(N, LogData) -> @@ -580,9 +602,9 @@ trim(N, LogData) -> %% Debug structure manipulating functions %%----------------------------------------------------------------- install_debug(Item, Data, Debug) -> - case get_debug2(Item, Debug, undefined) of - undefined -> [{Item, Data} | Debug]; - _ -> Debug + case lists:keysearch(Item, 1, Debug) of + false -> [{Item, Data} | Debug]; + _ -> Debug end. remove_debug(Item, Debug) -> lists:keydelete(Item, 1, Debug). @@ -633,7 +655,8 @@ close_log_file(Debug) -> | {'log_to_file', FileName} | {'install', FuncSpec}, FileName :: file:name(), - FuncSpec :: {Func, FuncState}, + FuncSpec :: {Func, FuncState} | {FuncId, Func, FuncState}, + FuncId :: term(), Func :: dbg_fun(), FuncState :: term(). debug_options(Options) -> @@ -648,7 +671,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 -> @@ -656,6 +679,8 @@ debug_options([{log_to_file, FileName} | T], Debug) -> end; debug_options([{install, {Func, FuncState}} | T], Debug) -> debug_options(T, install_debug(Func, FuncState, Debug)); +debug_options([{install, {FuncId, Func, FuncState}} | T], Debug) -> + debug_options(T, install_debug(FuncId, {Func, FuncState}, Debug)); debug_options([_ | T], Debug) -> debug_options(T, Debug); debug_options([], Debug) -> 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 617da11ba8..fbe8a94074 100644 --- a/lib/stdlib/src/unicode.erl +++ b/lib/stdlib/src/unicode.erl @@ -1,8 +1,8 @@ %% %% %CopyrightBegin% -%% -%% Copyright Ericsson AB 2008-2016. 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) -> @@ -577,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/uri_string.erl b/lib/stdlib/src/uri_string.erl new file mode 100644 index 0000000000..f07307c039 --- /dev/null +++ b/lib/stdlib/src/uri_string.erl @@ -0,0 +1,2148 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2017-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% +%% +%% +%% [RFC 3986, Chapter 2.2. Reserved Characters] +%% +%% reserved = gen-delims / sub-delims +%% +%% gen-delims = ":" / "/" / "?" / "#" / "[" / "]" / "@" +%% +%% sub-delims = "!" / "$" / "&" / "'" / "(" / ")" +%% / "*" / "+" / "," / ";" / "=" +%% +%% +%% [RFC 3986, Chapter 2.3. Unreserved Characters] +%% +%% unreserved = ALPHA / DIGIT / "-" / "." / "_" / "~" +%% +%% +%% [RFC 3986, Chapter 3. Syntax Components] +%% +%% The generic URI syntax consists of a hierarchical sequence of +%% components referred to as the scheme, authority, path, query, and +%% fragment. +%% +%% URI = scheme ":" hier-part [ "?" query ] [ "#" fragment ] +%% +%% hier-part = "//" authority path-abempty +%% / path-absolute +%% / path-rootless +%% / path-empty +%% +%% The scheme and path components are required, though the path may be +%% empty (no characters). When authority is present, the path must +%% either be empty or begin with a slash ("/") character. When +%% authority is not present, the path cannot begin with two slash +%% characters ("//"). These restrictions result in five different ABNF +%% rules for a path (Section 3.3), only one of which will match any +%% given URI reference. +%% +%% The following are two example URIs and their component parts: +%% +%% foo://example.com:8042/over/there?name=ferret#nose +%% \_/ \______________/\_________/ \_________/ \__/ +%% | | | | | +%% scheme authority path query fragment +%% | _____________________|__ +%% / \ / \ +%% urn:example:animal:ferret:nose +%% +%% +%% [RFC 3986, Chapter 3.1. Scheme] +%% +%% Each URI begins with a scheme name that refers to a specification for +%% assigning identifiers within that scheme. +%% +%% scheme = ALPHA *( ALPHA / DIGIT / "+" / "-" / "." ) +%% +%% +%% [RFC 3986, Chapter 3.2. Authority] +%% +%% Many URI schemes include a hierarchical element for a naming +%% authority so that governance of the name space defined by the +%% remainder of the URI is delegated to that authority (which may, in +%% turn, delegate it further). +%% +%% authority = [ userinfo "@" ] host [ ":" port ] +%% +%% +%% [RFC 3986, Chapter 3.2.1. User Information] +%% +%% The userinfo subcomponent may consist of a user name and, optionally, +%% scheme-specific information about how to gain authorization to access +%% the resource. The user information, if present, is followed by a +%% commercial at-sign ("@") that delimits it from the host. +%% +%% userinfo = *( unreserved / pct-encoded / sub-delims / ":" ) +%% +%% +%% [RFC 3986, Chapter 3.2.2. Host] +%% +%% The host subcomponent of authority is identified by an IP literal +%% encapsulated within square brackets, an IPv4 address in dotted- +%% decimal form, or a registered name. +%% +%% host = IP-literal / IPv4address / reg-name +%% +%% IP-literal = "[" ( IPv6address / IPvFuture ) "]" +%% +%% IPvFuture = "v" 1*HEXDIG "." 1*( unreserved / sub-delims / ":" ) +%% +%% IPv6address = 6( h16 ":" ) ls32 +%% / "::" 5( h16 ":" ) ls32 +%% / [ h16 ] "::" 4( h16 ":" ) ls32 +%% / [ *1( h16 ":" ) h16 ] "::" 3( h16 ":" ) ls32 +%% / [ *2( h16 ":" ) h16 ] "::" 2( h16 ":" ) ls32 +%% / [ *3( h16 ":" ) h16 ] "::" h16 ":" ls32 +%% / [ *4( h16 ":" ) h16 ] "::" ls32 +%% / [ *5( h16 ":" ) h16 ] "::" h16 +%% / [ *6( h16 ":" ) h16 ] "::" +%% +%% ls32 = ( h16 ":" h16 ) / IPv4address +%% ; least-significant 32 bits of address +%% +%% h16 = 1*4HEXDIG +%% ; 16 bits of address represented in hexadecimal +%% +%% IPv4address = dec-octet "." dec-octet "." dec-octet "." dec-octet +%% +%% dec-octet = DIGIT ; 0-9 +%% / %x31-39 DIGIT ; 10-99 +%% / "1" 2DIGIT ; 100-199 +%% / "2" %x30-34 DIGIT ; 200-249 +%% / "25" %x30-35 ; 250-255 +%% +%% reg-name = *( unreserved / pct-encoded / sub-delims ) +%% +%% +%% [RFC 3986, Chapter 3.2.2. Port] +%% +%% The port subcomponent of authority is designated by an optional port +%% number in decimal following the host and delimited from it by a +%% single colon (":") character. +%% +%% port = *DIGIT +%% +%% +%% [RFC 3986, Chapter 3.3. Path] +%% +%% The path component contains data, usually organized in hierarchical +%% form, that, along with data in the non-hierarchical query component +%% (Section 3.4), serves to identify a resource within the scope of the +%% URI's scheme and naming authority (if any). The path is terminated +%% by the first question mark ("?") or number sign ("#") character, or +%% by the end of the URI. +%% +%% path = path-abempty ; begins with "/" or is empty +%% / path-absolute ; begins with "/" but not "//" +%% / path-noscheme ; begins with a non-colon segment +%% / path-rootless ; begins with a segment +%% / path-empty ; zero characters +%% +%% path-abempty = *( "/" segment ) +%% path-absolute = "/" [ segment-nz *( "/" segment ) ] +%% path-noscheme = segment-nz-nc *( "/" segment ) +%% path-rootless = segment-nz *( "/" segment ) +%% path-empty = 0<pchar> +%% segment = *pchar +%% segment-nz = 1*pchar +%% segment-nz-nc = 1*( unreserved / pct-encoded / sub-delims / "@" ) +%% ; non-zero-length segment without any colon ":" +%% +%% pchar = unreserved / pct-encoded / sub-delims / ":" / "@" +%% +%% +%% [RFC 3986, Chapter 3.4. Query] +%% +%% The query component contains non-hierarchical data that, along with +%% data in the path component (Section 3.3), serves to identify a +%% resource within the scope of the URI's scheme and naming authority +%% (if any). The query component is indicated by the first question +%% mark ("?") character and terminated by a number sign ("#") character +%% or by the end of the URI. +%% +%% query = *( pchar / "/" / "?" ) +%% +%% +%% [RFC 3986, Chapter 3.5. Fragment] +%% +%% The fragment identifier component of a URI allows indirect +%% identification of a secondary resource by reference to a primary +%% resource and additional identifying information. +%% +%% fragment = *( pchar / "/" / "?" ) +%% +%% +%% [RFC 3986, Chapter 4.1. URI Reference] +%% +%% URI-reference is used to denote the most common usage of a resource +%% identifier. +%% +%% URI-reference = URI / relative-ref +%% +%% +%% [RFC 3986, Chapter 4.2. Relative Reference] +%% +%% A relative reference takes advantage of the hierarchical syntax +%% (Section 1.2.3) to express a URI reference relative to the name space +%% of another hierarchical URI. +%% +%% relative-ref = relative-part [ "?" query ] [ "#" fragment ] +%% +%% relative-part = "//" authority path-abempty +%% / path-absolute +%% / path-noscheme +%% / path-empty +%% +%% +%% [RFC 3986, Chapter 4.3. Absolute URI] +%% +%% Some protocol elements allow only the absolute form of a URI without +%% a fragment identifier. For example, defining a base URI for later +%% use by relative references calls for an absolute-URI syntax rule that +%% does not allow a fragment. +%% +%% absolute-URI = scheme ":" hier-part [ "?" query ] +%% +-module(uri_string). + +%%------------------------------------------------------------------------- +%% External API +%%------------------------------------------------------------------------- +-export([compose_query/1, compose_query/2, + dissect_query/1, normalize/1, normalize/2, parse/1, + recompose/1, transcode/2]). +-export_type([error/0, uri_map/0, uri_string/0]). + + +%%------------------------------------------------------------------------- +%% Internal API +%%------------------------------------------------------------------------- +-export([is_host/1, is_path/1]). % suppress warnings + + +%%------------------------------------------------------------------------- +%% Macros +%%------------------------------------------------------------------------- +-define(CHAR(Char), <<Char/utf8>>). +-define(STRING_EMPTY, <<>>). +-define(STRING(MatchStr), <<MatchStr/binary>>). +-define(STRING_REST(MatchStr, Rest), <<MatchStr/utf8, Rest/binary>>). + +-define(DEC2HEX(X), + if ((X) >= 0) andalso ((X) =< 9) -> (X) + $0; + ((X) >= 10) andalso ((X) =< 15) -> (X) + $A - 10 + end). + +-define(HEX2DEC(X), + if ((X) >= $0) andalso ((X) =< $9) -> (X) - $0; + ((X) >= $A) andalso ((X) =< $F) -> (X) - $A + 10; + ((X) >= $a) andalso ((X) =< $f) -> (X) - $a + 10 + end). + + +%%%========================================================================= +%%% API +%%%========================================================================= + +%%------------------------------------------------------------------------- +%% URI compliant with RFC 3986 +%% ASCII %x21 - %x7A ("!" - "z") except +%% %x34 " double quote +%% %x60 < less than +%% %x62 > greater than +%% %x92 \ backslash +%% %x94 ^ caret / circumflex +%% %x96 ` grave / accent +%%------------------------------------------------------------------------- +-type uri_string() :: iodata(). +-type error() :: {error, atom(), term()}. + + +%%------------------------------------------------------------------------- +%% RFC 3986, Chapter 3. Syntax Components +%%------------------------------------------------------------------------- +-type uri_map() :: + #{fragment => unicode:chardata(), + host => unicode:chardata(), + path => unicode:chardata(), + port => non_neg_integer() | undefined, + query => unicode:chardata(), + scheme => unicode:chardata(), + userinfo => unicode:chardata()} | #{}. + + +%%------------------------------------------------------------------------- +%% Normalize URIs +%%------------------------------------------------------------------------- +-spec normalize(URI) -> NormalizedURI when + URI :: uri_string() | uri_map(), + NormalizedURI :: uri_string() + | error(). +normalize(URIMap) -> + try normalize(URIMap, []) + catch + throw:{error, Atom, RestData} -> {error, Atom, RestData} + end. + + +-spec normalize(URI, Options) -> NormalizedURI when + URI :: uri_string() | uri_map(), + Options :: [return_map], + NormalizedURI :: uri_string() | uri_map(). +normalize(URIMap, []) when is_map(URIMap) -> + recompose(normalize_map(URIMap)); +normalize(URIMap, [return_map]) when is_map(URIMap) -> + normalize_map(URIMap); +normalize(URIString, []) -> + case parse(URIString) of + Value when is_map(Value) -> + recompose(normalize_map(Value)); + Error -> + Error + end; +normalize(URIString, [return_map]) -> + case parse(URIString) of + Value when is_map(Value) -> + normalize_map(Value); + Error -> + Error + end. + + +%%------------------------------------------------------------------------- +%% Parse URIs +%%------------------------------------------------------------------------- +-spec parse(URIString) -> URIMap when + URIString :: uri_string(), + URIMap :: uri_map() + | error(). +parse(URIString) when is_binary(URIString) -> + try parse_uri_reference(URIString, #{}) + catch + throw:{error, Atom, RestData} -> {error, Atom, RestData} + end; +parse(URIString) when is_list(URIString) -> + try + Binary = unicode:characters_to_binary(URIString), + Map = parse_uri_reference(Binary, #{}), + convert_mapfields_to_list(Map) + catch + throw:{error, Atom, RestData} -> {error, Atom, RestData} + end. + + +%%------------------------------------------------------------------------- +%% Recompose URIs +%%------------------------------------------------------------------------- +-spec recompose(URIMap) -> URIString when + URIMap :: uri_map(), + URIString :: uri_string() + | error(). +recompose(Map) -> + case is_valid_map(Map) of + false -> + {error, invalid_map, Map}; + true -> + try + T0 = update_scheme(Map, empty), + T1 = update_userinfo(Map, T0), + T2 = update_host(Map, T1), + T3 = update_port(Map, T2), + T4 = update_path(Map, T3), + T5 = update_query(Map, T4), + update_fragment(Map, T5) + catch + throw:{error, Atom, RestData} -> {error, Atom, RestData} + end + end. + + +%%------------------------------------------------------------------------- +%% Transcode URIs +%%------------------------------------------------------------------------- +-spec transcode(URIString, Options) -> Result when + URIString :: uri_string(), + Options :: [{in_encoding, unicode:encoding()}|{out_encoding, unicode:encoding()}], + Result :: uri_string() + | error(). +transcode(URIString, Options) when is_binary(URIString) -> + try + InEnc = proplists:get_value(in_encoding, Options, utf8), + OutEnc = proplists:get_value(out_encoding, Options, utf8), + List = convert_to_list(URIString, InEnc), + Output = transcode(List, [], InEnc, OutEnc), + convert_to_binary(Output, utf8, OutEnc) + catch + throw:{error, Atom, RestData} -> {error, Atom, RestData} + end; +transcode(URIString, Options) when is_list(URIString) -> + InEnc = proplists:get_value(in_encoding, Options, utf8), + OutEnc = proplists:get_value(out_encoding, Options, utf8), + Flattened = flatten_list(URIString, InEnc), + try transcode(Flattened, [], InEnc, OutEnc) + catch + throw:{error, Atom, RestData} -> {error, Atom, RestData} + end. + + +%%------------------------------------------------------------------------- +%% Functions for working with the query part of a URI as a list +%% of key/value pairs. +%% HTML 5.2 - 4.10.21.6 URL-encoded form data - WHATWG URL (10 Jan 2018) - UTF-8 +%% HTML 5.0 - 4.10.22.6 URL-encoded form data - non UTF-8 +%%------------------------------------------------------------------------- + +%%------------------------------------------------------------------------- +%% Compose urlencoded query string from a list of unescaped key/value pairs. +%% (application/x-www-form-urlencoded encoding algorithm) +%%------------------------------------------------------------------------- +-spec compose_query(QueryList) -> QueryString when + QueryList :: [{unicode:chardata(), unicode:chardata()}], + QueryString :: uri_string() + | error(). +compose_query(List) -> + compose_query(List, [{encoding, utf8}]). + + +-spec compose_query(QueryList, Options) -> QueryString when + QueryList :: [{unicode:chardata(), unicode:chardata()}], + Options :: [{encoding, atom()}], + QueryString :: uri_string() + | error(). +compose_query([],_Options) -> + []; +compose_query(List, Options) -> + try compose_query(List, Options, false, <<>>) + catch + throw:{error, Atom, RestData} -> {error, Atom, RestData} + end. +%% +compose_query([{Key,Value}|Rest], Options, IsList, Acc) -> + Separator = get_separator(Rest), + K = form_urlencode(Key, Options), + V = form_urlencode(Value, Options), + IsListNew = IsList orelse is_list(Key) orelse is_list(Value), + compose_query(Rest, Options, IsListNew, <<Acc/binary,K/binary,"=",V/binary,Separator/binary>>); +compose_query([], _Options, IsList, Acc) -> + case IsList of + true -> convert_to_list(Acc, utf8); + false -> Acc + end. + + +%%------------------------------------------------------------------------- +%% Dissect a query string into a list of unescaped key/value pairs. +%% (application/x-www-form-urlencoded decoding algorithm) +%%------------------------------------------------------------------------- +-spec dissect_query(QueryString) -> QueryList when + QueryString :: uri_string(), + QueryList :: [{unicode:chardata(), unicode:chardata()}] + | error(). +dissect_query(<<>>) -> + []; +dissect_query([]) -> + []; +dissect_query(QueryString) when is_list(QueryString) -> + try + B = convert_to_binary(QueryString, utf8, utf8), + dissect_query_key(B, true, [], <<>>, <<>>) + catch + throw:{error, Atom, RestData} -> {error, Atom, RestData} + end; +dissect_query(QueryString) -> + try dissect_query_key(QueryString, false, [], <<>>, <<>>) + catch + throw:{error, Atom, RestData} -> {error, Atom, RestData} + end. + + +%%%======================================================================== +%%% Internal functions +%%%======================================================================== + +%%------------------------------------------------------------------------- +%% Converts Map fields to lists +%%------------------------------------------------------------------------- +convert_mapfields_to_list(Map) -> + Fun = fun (_, V) when is_binary(V) -> unicode:characters_to_list(V); + (_, V) -> V end, + maps:map(Fun, Map). + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 4.1. URI Reference] +%% +%% URI-reference is used to denote the most common usage of a resource +%% identifier. +%% +%% URI-reference = URI / relative-ref +%%------------------------------------------------------------------------- +-spec parse_uri_reference(binary(), uri_map()) -> uri_map(). +parse_uri_reference(<<>>, _) -> #{path => <<>>}; +parse_uri_reference(URIString, URI) -> + try parse_scheme_start(URIString, URI) + catch + throw:{_,_,_} -> + parse_relative_part(URIString, URI) + end. + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 4.2. Relative Reference] +%% +%% A relative reference takes advantage of the hierarchical syntax +%% (Section 1.2.3) to express a URI reference relative to the name space +%% of another hierarchical URI. +%% +%% relative-ref = relative-part [ "?" query ] [ "#" fragment ] +%% +%% relative-part = "//" authority path-abempty +%% / path-absolute +%% / path-noscheme +%% / path-empty +%%------------------------------------------------------------------------- +-spec parse_relative_part(binary(), uri_map()) -> uri_map(). +parse_relative_part(?STRING_REST("//", Rest), URI) -> + %% Parse userinfo - "//" is NOT part of authority + try parse_userinfo(Rest, URI) of + {T, URI1} -> + Userinfo = calculate_parsed_userinfo(Rest, T), + URI2 = maybe_add_path(URI1), + URI2#{userinfo => Userinfo} + catch + throw:{_,_,_} -> + {T, URI1} = parse_host(Rest, URI), + Host = calculate_parsed_host_port(Rest, T), + URI2 = maybe_add_path(URI1), + URI2#{host => remove_brackets(Host)} + end; +parse_relative_part(?STRING_REST($/, Rest), URI) -> + {T, URI1} = parse_segment(Rest, URI), % path-absolute + Path = calculate_parsed_part(Rest, T), + URI1#{path => ?STRING_REST($/, Path)}; +parse_relative_part(?STRING_REST($?, Rest), URI) -> + {T, URI1} = parse_query(Rest, URI), % path-empty ?query + Query = calculate_parsed_query_fragment(Rest, T), + URI2 = maybe_add_path(URI1), + URI2#{query => Query}; +parse_relative_part(?STRING_REST($#, Rest), URI) -> + {T, URI1} = parse_fragment(Rest, URI), % path-empty + Fragment = calculate_parsed_query_fragment(Rest, T), + URI2 = maybe_add_path(URI1), + URI2#{fragment => Fragment}; +parse_relative_part(?STRING_REST(Char, Rest), URI) -> + case is_segment_nz_nc(Char) of + true -> + {T, URI1} = parse_segment_nz_nc(Rest, URI), % path-noscheme + Path = calculate_parsed_part(Rest, T), + URI1#{path => ?STRING_REST(Char, Path)}; + false -> throw({error,invalid_uri,[Char]}) + end. + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 3.3. Path] +%% +%% The path component contains data, usually organized in hierarchical +%% form, that, along with data in the non-hierarchical query component +%% (Section 3.4), serves to identify a resource within the scope of the +%% URI's scheme and naming authority (if any). The path is terminated +%% by the first question mark ("?") or number sign ("#") character, or +%% by the end of the URI. +%% +%% path = path-abempty ; begins with "/" or is empty +%% / path-absolute ; begins with "/" but not "//" +%% / path-noscheme ; begins with a non-colon segment +%% / path-rootless ; begins with a segment +%% / path-empty ; zero characters +%% +%% path-abempty = *( "/" segment ) +%% path-absolute = "/" [ segment-nz *( "/" segment ) ] +%% path-noscheme = segment-nz-nc *( "/" segment ) +%% path-rootless = segment-nz *( "/" segment ) +%% path-empty = 0<pchar> +%% segment = *pchar +%% segment-nz = 1*pchar +%% segment-nz-nc = 1*( unreserved / pct-encoded / sub-delims / "@" ) +%% ; non-zero-length segment without any colon ":" +%% +%% pchar = unreserved / pct-encoded / sub-delims / ":" / "@" +%%------------------------------------------------------------------------- + +%%------------------------------------------------------------------------- +%% path-abempty +%%------------------------------------------------------------------------- +-spec parse_segment(binary(), uri_map()) -> {binary(), uri_map()}. +parse_segment(?STRING_REST($/, Rest), URI) -> + parse_segment(Rest, URI); % segment +parse_segment(?STRING_REST($?, Rest), URI) -> + {T, URI1} = parse_query(Rest, URI), % ?query + Query = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{query => Query}}; +parse_segment(?STRING_REST($#, Rest), URI) -> + {T, URI1} = parse_fragment(Rest, URI), + Fragment = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{fragment => Fragment}}; +parse_segment(?STRING_REST(Char, Rest), URI) -> + case is_pchar(Char) of + true -> parse_segment(Rest, URI); + false -> throw({error,invalid_uri,[Char]}) + end; +parse_segment(?STRING_EMPTY, URI) -> + {?STRING_EMPTY, URI}. + + +%%------------------------------------------------------------------------- +%% path-noscheme +%%------------------------------------------------------------------------- +-spec parse_segment_nz_nc(binary(), uri_map()) -> {binary(), uri_map()}. +parse_segment_nz_nc(?STRING_REST($/, Rest), URI) -> + parse_segment(Rest, URI); % segment +parse_segment_nz_nc(?STRING_REST($?, Rest), URI) -> + {T, URI1} = parse_query(Rest, URI), % ?query + Query = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{query => Query}}; +parse_segment_nz_nc(?STRING_REST($#, Rest), URI) -> + {T, URI1} = parse_fragment(Rest, URI), + Fragment = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{fragment => Fragment}}; +parse_segment_nz_nc(?STRING_REST(Char, Rest), URI) -> + case is_segment_nz_nc(Char) of + true -> parse_segment_nz_nc(Rest, URI); + false -> throw({error,invalid_uri,[Char]}) + end; +parse_segment_nz_nc(?STRING_EMPTY, URI) -> + {?STRING_EMPTY, URI}. + + +%% Check if char is pchar. +-spec is_pchar(char()) -> boolean(). +is_pchar($%) -> true; % pct-encoded +is_pchar($:) -> true; +is_pchar($@) -> true; +is_pchar(Char) -> is_unreserved(Char) orelse is_sub_delim(Char). + +%% Check if char is segment_nz_nc. +-spec is_segment_nz_nc(char()) -> boolean(). +is_segment_nz_nc($%) -> true; % pct-encoded +is_segment_nz_nc($@) -> true; +is_segment_nz_nc(Char) -> is_unreserved(Char) orelse is_sub_delim(Char). + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 3.1. Scheme] +%% +%% Each URI begins with a scheme name that refers to a specification for +%% assigning identifiers within that scheme. +%% +%% scheme = ALPHA *( ALPHA / DIGIT / "+" / "-" / "." ) +%%------------------------------------------------------------------------- +-spec parse_scheme_start(binary(), uri_map()) -> uri_map(). +parse_scheme_start(?STRING_REST(Char, Rest), URI) -> + case is_alpha(Char) of + true -> {T, URI1} = parse_scheme(Rest, URI), + Scheme = calculate_parsed_scheme(Rest, T), + URI2 = maybe_add_path(URI1), + URI2#{scheme => ?STRING_REST(Char, Scheme)}; + false -> throw({error,invalid_uri,[Char]}) + end. + +%% Add path component if it missing after parsing the URI. +%% According to the URI specification there is always a +%% path component in every URI-reference and it can be +%% empty. +maybe_add_path(Map) -> + case maps:is_key(path, Map) of + false -> + Map#{path => <<>>}; + _Else -> + Map + end. + + + +-spec parse_scheme(binary(), uri_map()) -> {binary(), uri_map()}. +parse_scheme(?STRING_REST($:, Rest), URI) -> + {_, URI1} = parse_hier(Rest, URI), + {Rest, URI1}; +parse_scheme(?STRING_REST(Char, Rest), URI) -> + case is_scheme(Char) of + true -> parse_scheme(Rest, URI); + false -> throw({error,invalid_uri,[Char]}) + end; +parse_scheme(?STRING_EMPTY, _URI) -> + throw({error,invalid_uri,<<>>}). + + +%% Check if char is allowed in scheme +-spec is_scheme(char()) -> boolean(). +is_scheme($+) -> true; +is_scheme($-) -> true; +is_scheme($.) -> true; +is_scheme(Char) -> is_alpha(Char) orelse is_digit(Char). + + +%%------------------------------------------------------------------------- +%% hier-part = "//" authority path-abempty +%% / path-absolute +%% / path-rootless +%% / path-empty +%%------------------------------------------------------------------------- +-spec parse_hier(binary(), uri_map()) -> {binary(), uri_map()}. +parse_hier(?STRING_REST("//", Rest), URI) -> + % Parse userinfo - "//" is NOT part of authority + try parse_userinfo(Rest, URI) of + {T, URI1} -> + Userinfo = calculate_parsed_userinfo(Rest, T), + {Rest, URI1#{userinfo => Userinfo}} + catch + throw:{_,_,_} -> + {T, URI1} = parse_host(Rest, URI), + Host = calculate_parsed_host_port(Rest, T), + {Rest, URI1#{host => remove_brackets(Host)}} + end; +parse_hier(?STRING_REST($/, Rest), URI) -> + {T, URI1} = parse_segment(Rest, URI), % path-absolute + Path = calculate_parsed_part(Rest, T), + {Rest, URI1#{path => ?STRING_REST($/, Path)}}; +parse_hier(?STRING_REST($?, Rest), URI) -> + {T, URI1} = parse_query(Rest, URI), % path-empty ?query + Query = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{query => Query}}; +parse_hier(?STRING_REST($#, Rest), URI) -> + {T, URI1} = parse_fragment(Rest, URI), % path-empty + Fragment = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{fragment => Fragment}}; +parse_hier(?STRING_REST(Char, Rest), URI) -> % path-rootless + case is_pchar(Char) of + true -> % segment_nz + {T, URI1} = parse_segment(Rest, URI), + Path = calculate_parsed_part(Rest, T), + {Rest, URI1#{path => ?STRING_REST(Char, Path)}}; + false -> throw({error,invalid_uri,[Char]}) + end; +parse_hier(?STRING_EMPTY, URI) -> + {<<>>, URI}. + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 3.2. Authority] +%% +%% Many URI schemes include a hierarchical element for a naming +%% authority so that governance of the name space defined by the +%% remainder of the URI is delegated to that authority (which may, in +%% turn, delegate it further). +%% +%% The authority component is preceded by a double slash ("//") and is +%% terminated by the next slash ("/"), question mark ("?"), or number +%% sign ("#") character, or by the end of the URI. +%% +%% authority = [ userinfo "@" ] host [ ":" port ] +%% +%% +%% [RFC 3986, Chapter 3.2.1. User Information] +%% +%% The userinfo subcomponent may consist of a user name and, optionally, +%% scheme-specific information about how to gain authorization to access +%% the resource. The user information, if present, is followed by a +%% commercial at-sign ("@") that delimits it from the host. +%% +%% userinfo = *( unreserved / pct-encoded / sub-delims / ":" ) +%%------------------------------------------------------------------------- +-spec parse_userinfo(binary(), uri_map()) -> {binary(), uri_map()}. +parse_userinfo(?CHAR($@), URI) -> + {?STRING_EMPTY, URI#{host => <<>>}}; +parse_userinfo(?STRING_REST($@, Rest), URI) -> + {T, URI1} = parse_host(Rest, URI), + Host = calculate_parsed_host_port(Rest, T), + {Rest, URI1#{host => remove_brackets(Host)}}; +parse_userinfo(?STRING_REST(Char, Rest), URI) -> + case is_userinfo(Char) of + true -> parse_userinfo(Rest, URI); + false -> throw({error,invalid_uri,[Char]}) + end; +parse_userinfo(?STRING_EMPTY, _URI) -> + %% URI cannot end in userinfo state + throw({error,invalid_uri,<<>>}). + + +%% Check if char is allowed in userinfo +-spec is_userinfo(char()) -> boolean(). +is_userinfo($%) -> true; % pct-encoded +is_userinfo($:) -> true; +is_userinfo(Char) -> is_unreserved(Char) orelse is_sub_delim(Char). + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 3.2.2. Host] +%% +%% The host subcomponent of authority is identified by an IP literal +%% encapsulated within square brackets, an IPv4 address in dotted- +%% decimal form, or a registered name. +%% +%% host = IP-literal / IPv4address / reg-name +%% +%% IP-literal = "[" ( IPv6address / IPvFuture ) "]" +%% +%% IPvFuture = "v" 1*HEXDIG "." 1*( unreserved / sub-delims / ":" ) +%% +%% IPv6address = 6( h16 ":" ) ls32 +%% / "::" 5( h16 ":" ) ls32 +%% / [ h16 ] "::" 4( h16 ":" ) ls32 +%% / [ *1( h16 ":" ) h16 ] "::" 3( h16 ":" ) ls32 +%% / [ *2( h16 ":" ) h16 ] "::" 2( h16 ":" ) ls32 +%% / [ *3( h16 ":" ) h16 ] "::" h16 ":" ls32 +%% / [ *4( h16 ":" ) h16 ] "::" ls32 +%% / [ *5( h16 ":" ) h16 ] "::" h16 +%% / [ *6( h16 ":" ) h16 ] "::" +%% +%% ls32 = ( h16 ":" h16 ) / IPv4address +%% ; least-significant 32 bits of address +%% +%% h16 = 1*4HEXDIG +%% ; 16 bits of address represented in hexadecimal +%% +%% IPv4address = dec-octet "." dec-octet "." dec-octet "." dec-octet +%% +%% dec-octet = DIGIT ; 0-9 +%% / %x31-39 DIGIT ; 10-99 +%% / "1" 2DIGIT ; 100-199 +%% / "2" %x30-34 DIGIT ; 200-249 +%% / "25" %x30-35 ; 250-255 +%% +%% reg-name = *( unreserved / pct-encoded / sub-delims ) +%%------------------------------------------------------------------------- +-spec parse_host(binary(), uri_map()) -> {binary(), uri_map()}. +parse_host(?STRING_REST($:, Rest), URI) -> + {T, URI1} = parse_port(Rest, URI), + H = calculate_parsed_host_port(Rest, T), + Port = get_port(H), + {Rest, URI1#{port => Port}}; +parse_host(?STRING_REST($/, Rest), URI) -> + {T, URI1} = parse_segment(Rest, URI), % path-abempty + Path = calculate_parsed_part(Rest, T), + {Rest, URI1#{path => ?STRING_REST($/, Path)}}; +parse_host(?STRING_REST($?, Rest), URI) -> + {T, URI1} = parse_query(Rest, URI), % path-empty ?query + Query = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{query => Query}}; +parse_host(?STRING_REST($[, Rest), URI) -> + parse_ipv6_bin(Rest, [], URI); +parse_host(?STRING_REST($#, Rest), URI) -> + {T, URI1} = parse_fragment(Rest, URI), % path-empty + Fragment = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{fragment => Fragment}}; +parse_host(?STRING_REST(Char, Rest), URI) -> + case is_digit(Char) of + true -> + try parse_ipv4_bin(Rest, [Char], URI) + catch + throw:{_,_,_} -> + parse_reg_name(?STRING_REST(Char, Rest), URI) + end; + false -> parse_reg_name(?STRING_REST(Char, Rest), URI) + end; +parse_host(?STRING_EMPTY, URI) -> + {?STRING_EMPTY, URI}. + + +-spec parse_reg_name(binary(), uri_map()) -> {binary(), uri_map()}. +parse_reg_name(?STRING_REST($:, Rest), URI) -> + {T, URI1} = parse_port(Rest, URI), + H = calculate_parsed_host_port(Rest, T), + Port = get_port(H), + {Rest, URI1#{port => Port}}; +parse_reg_name(?STRING_REST($/, Rest), URI) -> + {T, URI1} = parse_segment(Rest, URI), % path-abempty + Path = calculate_parsed_part(Rest, T), + {Rest, URI1#{path => ?STRING_REST($/, Path)}}; +parse_reg_name(?STRING_REST($?, Rest), URI) -> + {T, URI1} = parse_query(Rest, URI), % path-empty ?query + Query = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{query => Query}}; +parse_reg_name(?STRING_REST($#, Rest), URI) -> + {T, URI1} = parse_fragment(Rest, URI), % path-empty + Fragment = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{fragment => Fragment}}; +parse_reg_name(?STRING_REST(Char, Rest), URI) -> + case is_reg_name(Char) of + true -> parse_reg_name(Rest, URI); + false -> throw({error,invalid_uri,[Char]}) + end; +parse_reg_name(?STRING_EMPTY, URI) -> + {?STRING_EMPTY, URI}. + +%% Check if char is allowed in reg-name +-spec is_reg_name(char()) -> boolean(). +is_reg_name($%) -> true; +is_reg_name(Char) -> is_unreserved(Char) orelse is_sub_delim(Char). + + +-spec parse_ipv4_bin(binary(), list(), uri_map()) -> {binary(), uri_map()}. +parse_ipv4_bin(?STRING_REST($:, Rest), Acc, URI) -> + _ = validate_ipv4_address(lists:reverse(Acc)), + {T, URI1} = parse_port(Rest, URI), + H = calculate_parsed_host_port(Rest, T), + Port = get_port(H), + {Rest, URI1#{port => Port}}; +parse_ipv4_bin(?STRING_REST($/, Rest), Acc, URI) -> + _ = validate_ipv4_address(lists:reverse(Acc)), + {T, URI1} = parse_segment(Rest, URI), % path-abempty + Path = calculate_parsed_part(Rest, T), + {Rest, URI1#{path => ?STRING_REST($/, Path)}}; +parse_ipv4_bin(?STRING_REST($?, Rest), Acc, URI) -> + _ = validate_ipv4_address(lists:reverse(Acc)), + {T, URI1} = parse_query(Rest, URI), % path-empty ?query + Query = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{query => Query}}; +parse_ipv4_bin(?STRING_REST($#, Rest), Acc, URI) -> + _ = validate_ipv4_address(lists:reverse(Acc)), + {T, URI1} = parse_fragment(Rest, URI), % path-empty + Fragment = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{fragment => Fragment}}; +parse_ipv4_bin(?STRING_REST(Char, Rest), Acc, URI) -> + case is_ipv4(Char) of + true -> parse_ipv4_bin(Rest, [Char|Acc], URI); + false -> throw({error,invalid_uri,[Char]}) + end; +parse_ipv4_bin(?STRING_EMPTY, Acc, URI) -> + _ = validate_ipv4_address(lists:reverse(Acc)), + {?STRING_EMPTY, URI}. + + +%% Check if char is allowed in IPv4 addresses +-spec is_ipv4(char()) -> boolean(). +is_ipv4($.) -> true; +is_ipv4(Char) -> is_digit(Char). + +-spec validate_ipv4_address(list()) -> list(). +validate_ipv4_address(Addr) -> + case inet:parse_ipv4strict_address(Addr) of + {ok, _} -> Addr; + {error, _} -> throw({error,invalid_uri,Addr}) + end. + + +-spec parse_ipv6_bin(binary(), list(), uri_map()) -> {binary(), uri_map()}. +parse_ipv6_bin(?STRING_REST($], Rest), Acc, URI) -> + _ = validate_ipv6_address(lists:reverse(Acc)), + parse_ipv6_bin_end(Rest, URI); +parse_ipv6_bin(?STRING_REST(Char, Rest), Acc, URI) -> + case is_ipv6(Char) of + true -> parse_ipv6_bin(Rest, [Char|Acc], URI); + false -> throw({error,invalid_uri,[Char]}) + end; +parse_ipv6_bin(?STRING_EMPTY, _Acc, _URI) -> + throw({error,invalid_uri,<<>>}). + +%% Check if char is allowed in IPv6 addresses +-spec is_ipv6(char()) -> boolean(). +is_ipv6($:) -> true; +is_ipv6($.) -> true; +is_ipv6(Char) -> is_hex_digit(Char). + + +-spec parse_ipv6_bin_end(binary(), uri_map()) -> {binary(), uri_map()}. +parse_ipv6_bin_end(?STRING_REST($:, Rest), URI) -> + {T, URI1} = parse_port(Rest, URI), + H = calculate_parsed_host_port(Rest, T), + Port = get_port(H), + {Rest, URI1#{port => Port}}; +parse_ipv6_bin_end(?STRING_REST($/, Rest), URI) -> + {T, URI1} = parse_segment(Rest, URI), % path-abempty + Path = calculate_parsed_part(Rest, T), + {Rest, URI1#{path => ?STRING_REST($/, Path)}}; +parse_ipv6_bin_end(?STRING_REST($?, Rest), URI) -> + {T, URI1} = parse_query(Rest, URI), % path-empty ?query + Query = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{query => Query}}; +parse_ipv6_bin_end(?STRING_REST($#, Rest), URI) -> + {T, URI1} = parse_fragment(Rest, URI), % path-empty + Fragment = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{fragment => Fragment}}; +parse_ipv6_bin_end(?STRING_REST(Char, Rest), URI) -> + case is_ipv6(Char) of + true -> parse_ipv6_bin_end(Rest, URI); + false -> throw({error,invalid_uri,[Char]}) + end; +parse_ipv6_bin_end(?STRING_EMPTY, URI) -> + {?STRING_EMPTY, URI}. + +-spec validate_ipv6_address(list()) -> list(). +validate_ipv6_address(Addr) -> + case inet:parse_ipv6strict_address(Addr) of + {ok, _} -> Addr; + {error, _} -> throw({error,invalid_uri,Addr}) + end. + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 3.2.2. Port] +%% +%% The port subcomponent of authority is designated by an optional port +%% number in decimal following the host and delimited from it by a +%% single colon (":") character. +%% +%% port = *DIGIT +%%------------------------------------------------------------------------- +-spec parse_port(binary(), uri_map()) -> {binary(), uri_map()}. +parse_port(?STRING_REST($/, Rest), URI) -> + {T, URI1} = parse_segment(Rest, URI), % path-abempty + Path = calculate_parsed_part(Rest, T), + {Rest, URI1#{path => ?STRING_REST($/, Path)}}; +parse_port(?STRING_REST($?, Rest), URI) -> + {T, URI1} = parse_query(Rest, URI), % path-empty ?query + Query = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{query => Query}}; +parse_port(?STRING_REST($#, Rest), URI) -> + {T, URI1} = parse_fragment(Rest, URI), % path-empty + Fragment = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{fragment => Fragment}}; +parse_port(?STRING_REST(Char, Rest), URI) -> + case is_digit(Char) of + true -> parse_port(Rest, URI); + false -> throw({error,invalid_uri,[Char]}) + end; +parse_port(?STRING_EMPTY, URI) -> + {?STRING_EMPTY, URI}. + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 3.4. Query] +%% +%% The query component contains non-hierarchical data that, along with +%% data in the path component (Section 3.3), serves to identify a +%% resource within the scope of the URI's scheme and naming authority +%% (if any). The query component is indicated by the first question +%% mark ("?") character and terminated by a number sign ("#") character +%% or by the end of the URI. +%% +%% query = *( pchar / "/" / "?" ) +%%------------------------------------------------------------------------- +-spec parse_query(binary(), uri_map()) -> {binary(), uri_map()}. +parse_query(?STRING_REST($#, Rest), URI) -> + {T, URI1} = parse_fragment(Rest, URI), + Fragment = calculate_parsed_query_fragment(Rest, T), + {Rest, URI1#{fragment => Fragment}}; +parse_query(?STRING_REST(Char, Rest), URI) -> + case is_query(Char) of + true -> parse_query(Rest, URI); + false -> throw({error,invalid_uri,[Char]}) + end; +parse_query(?STRING_EMPTY, URI) -> + {?STRING_EMPTY, URI}. + + +%% Check if char is allowed in query +-spec is_query(char()) -> boolean(). +is_query($/) -> true; +is_query($?) -> true; +is_query(Char) -> is_pchar(Char). + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 3.5. Fragment] +%% +%% The fragment identifier component of a URI allows indirect +%% identification of a secondary resource by reference to a primary +%% resource and additional identifying information. +%% +%% fragment = *( pchar / "/" / "?" ) +%%------------------------------------------------------------------------- +-spec parse_fragment(binary(), uri_map()) -> {binary(), uri_map()}. +parse_fragment(?STRING_REST(Char, Rest), URI) -> + case is_fragment(Char) of + true -> parse_fragment(Rest, URI); + false -> throw({error,invalid_uri,[Char]}) + end; +parse_fragment(?STRING_EMPTY, URI) -> + {?STRING_EMPTY, URI}. + + +%% Check if char is allowed in fragment +-spec is_fragment(char()) -> boolean(). +is_fragment($/) -> true; +is_fragment($?) -> true; +is_fragment(Char) -> is_pchar(Char). + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 2.2. Reserved Characters] +%% +%% reserved = gen-delims / sub-delims +%% +%% gen-delims = ":" / "/" / "?" / "#" / "[" / "]" / "@" +%% +%% sub-delims = "!" / "$" / "&" / "'" / "(" / ")" +%% / "*" / "+" / "," / ";" / "=" +%% +%%------------------------------------------------------------------------- + +%% Return true if input char is reserved. +-spec is_reserved(char()) -> boolean(). +is_reserved($:) -> true; +is_reserved($/) -> true; +is_reserved($?) -> true; +is_reserved($#) -> true; +is_reserved($[) -> true; +is_reserved($]) -> true; +is_reserved($@) -> true; + +is_reserved($!) -> true; +is_reserved($$) -> true; +is_reserved($&) -> true; +is_reserved($') -> true; +is_reserved($() -> true; +is_reserved($)) -> true; + +is_reserved($*) -> true; +is_reserved($+) -> true; +is_reserved($,) -> true; +is_reserved($;) -> true; +is_reserved($=) -> true; +is_reserved(_) -> false. + + +%% Check if char is sub-delim. +-spec is_sub_delim(char()) -> boolean(). +is_sub_delim($!) -> true; +is_sub_delim($$) -> true; +is_sub_delim($&) -> true; +is_sub_delim($') -> true; +is_sub_delim($() -> true; +is_sub_delim($)) -> true; + +is_sub_delim($*) -> true; +is_sub_delim($+) -> true; +is_sub_delim($,) -> true; +is_sub_delim($;) -> true; +is_sub_delim($=) -> true; +is_sub_delim(_) -> false. + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 2.3. Unreserved Characters] +%% +%% unreserved = ALPHA / DIGIT / "-" / "." / "_" / "~" +%% +%%------------------------------------------------------------------------- +-spec is_unreserved(char()) -> boolean(). +is_unreserved($-) -> true; +is_unreserved($.) -> true; +is_unreserved($_) -> true; +is_unreserved($~) -> true; +is_unreserved(Char) -> is_alpha(Char) orelse is_digit(Char). + +-spec is_alpha(char()) -> boolean(). +is_alpha(C) + when $A =< C, C =< $Z; + $a =< C, C =< $z -> true; +is_alpha(_) -> false. + +-spec is_digit(char()) -> boolean(). +is_digit(C) + when $0 =< C, C =< $9 -> true; +is_digit(_) -> false. + +-spec is_hex_digit(char()) -> boolean(). +is_hex_digit(C) + when $0 =< C, C =< $9;$a =< C, C =< $f;$A =< C, C =< $F -> true; +is_hex_digit(_) -> false. + + +%% Remove enclosing brackets from binary +-spec remove_brackets(binary()) -> binary(). +remove_brackets(<<$[/utf8, Rest/binary>>) -> + {H,T} = split_binary(Rest, byte_size(Rest) - 1), + case T =:= <<$]/utf8>> of + true -> H; + false -> Rest + end; +remove_brackets(Addr) -> Addr. + + +%%------------------------------------------------------------------------- +%% Helper functions for calculating the parsed binary. +%%------------------------------------------------------------------------- +-spec calculate_parsed_scheme(binary(), binary()) -> binary(). +calculate_parsed_scheme(Input, <<>>) -> + strip_last_char(Input, [$:]); +calculate_parsed_scheme(Input, Unparsed) -> + get_parsed_binary(Input, Unparsed). + + +-spec calculate_parsed_part(binary(), binary()) -> binary(). +calculate_parsed_part(Input, <<>>) -> + strip_last_char(Input, [$?,$#]); +calculate_parsed_part(Input, Unparsed) -> + get_parsed_binary(Input, Unparsed). + + +-spec calculate_parsed_userinfo(binary(), binary()) -> binary(). +calculate_parsed_userinfo(Input, <<>>) -> + strip_last_char(Input, [$?,$#,$@]); +calculate_parsed_userinfo(Input, Unparsed) -> + get_parsed_binary(Input, Unparsed). + + +-spec calculate_parsed_host_port(binary(), binary()) -> binary(). +calculate_parsed_host_port(Input, <<>>) -> + strip_last_char(Input, [$:,$?,$#,$/]); +calculate_parsed_host_port(Input, Unparsed) -> + get_parsed_binary(Input, Unparsed). + + +calculate_parsed_query_fragment(Input, <<>>) -> + strip_last_char(Input, [$#]); +calculate_parsed_query_fragment(Input, Unparsed) -> + get_parsed_binary(Input, Unparsed). + + +get_port(<<>>) -> + undefined; +get_port(B) -> + try binary_to_integer(B) + catch + error:badarg -> + throw({error, invalid_uri, B}) + end. + + +%% Strip last char if it is in list +%% +%% This function is optimized for speed: parse/1 is about 10% faster than +%% with an alternative implementation based on lists and sets. +strip_last_char(<<>>, _) -> <<>>; +strip_last_char(Input, [C0]) -> + case binary:last(Input) of + C0 -> + init_binary(Input); + _Else -> + Input + end; +strip_last_char(Input, [C0,C1]) -> + case binary:last(Input) of + C0 -> + init_binary(Input); + C1 -> + init_binary(Input); + _Else -> + Input + end; +strip_last_char(Input, [C0,C1,C2]) -> + case binary:last(Input) of + C0 -> + init_binary(Input); + C1 -> + init_binary(Input); + C2 -> + init_binary(Input); + _Else -> + Input + end; +strip_last_char(Input, [C0,C1,C2,C3]) -> + case binary:last(Input) of + C0 -> + init_binary(Input); + C1 -> + init_binary(Input); + C2 -> + init_binary(Input); + C3 -> + init_binary(Input); + _Else -> + Input + end. + + +%% Get parsed binary +get_parsed_binary(Input, Unparsed) -> + {First, _} = split_binary(Input, byte_size(Input) - byte_size_exl_head(Unparsed)), + First. + + +%% Return all bytes of the binary except the last one. The binary must be non-empty. +init_binary(B) -> + {Init, _} = + split_binary(B, byte_size(B) - 1), + Init. + + +%% Returns the size of a binary exluding the first element. +%% Used in calls to split_binary(). +-spec byte_size_exl_head(binary()) -> number(). +byte_size_exl_head(<<>>) -> 0; +byte_size_exl_head(Binary) -> byte_size(Binary) + 1. + + +%%------------------------------------------------------------------------- +%% [RFC 3986, Chapter 2.1. Percent-Encoding] +%% +%% A percent-encoding mechanism is used to represent a data octet in a +%% component when that octet's corresponding character is outside the +%% allowed set or is being used as a delimiter of, or within, the +%% component. A percent-encoded octet is encoded as a character +%% triplet, consisting of the percent character "%" followed by the two +%% hexadecimal digits representing that octet's numeric value. For +%% example, "%20" is the percent-encoding for the binary octet +%% "00100000" (ABNF: %x20), which in US-ASCII corresponds to the space +%% character (SP). Section 2.4 describes when percent-encoding and +%% decoding is applied. +%% +%% pct-encoded = "%" HEXDIG HEXDIG +%%------------------------------------------------------------------------- + +%%------------------------------------------------------------------------- +%% Percent-encode +%%------------------------------------------------------------------------- + +%% Only validates as scheme cannot have percent-encoded characters +-spec encode_scheme(list()|binary()) -> list() | binary(). +encode_scheme([]) -> + throw({error,invalid_scheme,""}); +encode_scheme(<<>>) -> + throw({error,invalid_scheme,<<>>}); +encode_scheme(Scheme) -> + case validate_scheme(Scheme) of + true -> Scheme; + false -> throw({error,invalid_scheme,Scheme}) + end. + +-spec encode_userinfo(list()|binary()) -> list() | binary(). +encode_userinfo(Cs) -> + encode(Cs, fun is_userinfo/1). + +-spec encode_host(list()|binary()) -> list() | binary(). +encode_host(Cs) -> + case classify_host(Cs) of + regname -> Cs; + ipv4 -> Cs; + ipv6 -> bracket_ipv6(Cs); + other -> encode(Cs, fun is_reg_name/1) + end. + +-spec encode_path(list()|binary()) -> list() | binary(). +encode_path(Cs) -> + encode(Cs, fun is_path/1). + +-spec encode_query(list()|binary()) -> list() | binary(). +encode_query(Cs) -> + encode(Cs, fun is_query/1). + +-spec encode_fragment(list()|binary()) -> list() | binary(). +encode_fragment(Cs) -> + encode(Cs, fun is_fragment/1). + +%%------------------------------------------------------------------------- +%% Helper funtions for percent-decode +%%------------------------------------------------------------------------- + +-spec decode(list()|binary()) -> list() | binary(). +decode(Cs) -> + decode(Cs, <<>>). +%% +decode(L, Acc) when is_list(L) -> + B0 = unicode:characters_to_binary(L), + B1 = decode(B0, Acc), + unicode:characters_to_list(B1); +decode(<<$%,C0,C1,Cs/binary>>, Acc) -> + case is_hex_digit(C0) andalso is_hex_digit(C1) of + true -> + B = ?HEX2DEC(C0)*16+?HEX2DEC(C1), + case is_reserved(B) of + true -> + %% [2.2] Characters in the reserved set are protected from + %% normalization. + %% [2.1] For consistency, URI producers and normalizers should + %% use uppercase hexadecimal digits for all percent- + %% encodings. + H0 = hex_to_upper(C0), + H1 = hex_to_upper(C1), + decode(Cs, <<Acc/binary,$%,H0,H1>>); + false -> + decode(Cs, <<Acc/binary, B>>) + end; + false -> throw({error,invalid_percent_encoding,<<$%,C0,C1>>}) + end; +decode(<<C,Cs/binary>>, Acc) -> + decode(Cs, <<Acc/binary, C>>); +decode(<<>>, Acc) -> + check_utf8(Acc). + +%% Returns Cs if it is utf8 encoded. +check_utf8(Cs) -> + case unicode:characters_to_list(Cs) of + {incomplete,_,_} -> + throw({error,invalid_utf8,Cs}); + {error,_,_} -> + throw({error,invalid_utf8,Cs}); + _ -> Cs + end. + +%% Convert hex digit to uppercase form +hex_to_upper(H) when $a =< H, H =< $f -> + H - 32; +hex_to_upper(H) when $0 =< H, H =< $9;$A =< H, H =< $F-> + H; +hex_to_upper(H) -> + throw({error,invalid_input, H}). + +%% Check if char is allowed in host +-spec is_host(char()) -> boolean(). +is_host($:) -> true; +is_host(Char) -> is_unreserved(Char) orelse is_sub_delim(Char). + +%% Check if char is allowed in path +-spec is_path(char()) -> boolean(). +is_path($/) -> true; +is_path(Char) -> is_pchar(Char). + + +%%------------------------------------------------------------------------- +%% Helper functions for percent-encode +%%------------------------------------------------------------------------- +-spec encode(list()|binary(), fun()) -> list() | binary(). +encode(Component, Fun) when is_list(Component) -> + B = unicode:characters_to_binary(Component), + unicode:characters_to_list(encode(B, Fun, <<>>)); +encode(Component, Fun) when is_binary(Component) -> + encode(Component, Fun, <<>>). +%% +encode(<<Char/utf8, Rest/binary>>, Fun, Acc) -> + C = encode_codepoint_binary(Char, Fun), + encode(Rest, Fun, <<Acc/binary,C/binary>>); +encode(<<Char, Rest/binary>>, _Fun, _Acc) -> + throw({error,invalid_input,<<Char,Rest/binary>>}); +encode(<<>>, _Fun, Acc) -> + Acc. + + +-spec encode_codepoint_binary(integer(), fun()) -> binary(). +encode_codepoint_binary(C, Fun) -> + case Fun(C) of + false -> percent_encode_binary(C); + true -> <<C>> + end. + + +-spec percent_encode_binary(integer()) -> binary(). +percent_encode_binary(Code) -> + percent_encode_binary(<<Code/utf8>>, <<>>). + + +percent_encode_binary(<<A:4,B:4,Rest/binary>>, Acc) -> + percent_encode_binary(Rest, <<Acc/binary,$%,(?DEC2HEX(A)),(?DEC2HEX(B))>>); +percent_encode_binary(<<>>, Acc) -> + Acc. + + +%%------------------------------------------------------------------------- +%%------------------------------------------------------------------------- +validate_scheme([]) -> true; +validate_scheme([H|T]) -> + case is_scheme(H) of + true -> validate_scheme(T); + false -> false + end; +validate_scheme(<<>>) -> true; +validate_scheme(<<H, Rest/binary>>) -> + case is_scheme(H) of + true -> validate_scheme(Rest); + false -> false + end. + + +%%------------------------------------------------------------------------- +%% Classifies hostname into the following categories: +%% regname, ipv4 - address does not contain reserved characters to be +%% percent-encoded +%% ipv6 - address does not contain reserved characters but it shall be +%% encolsed in brackets +%% other - address shall be percent-encoded +%%------------------------------------------------------------------------- +classify_host([]) -> other; +classify_host(Addr) when is_binary(Addr) -> + A = unicode:characters_to_list(Addr), + classify_host_ipv6(A); +classify_host(Addr) -> + classify_host_ipv6(Addr). + +classify_host_ipv6(Addr) -> + case is_ipv6_address(Addr) of + true -> ipv6; + false -> classify_host_ipv4(Addr) + end. + +classify_host_ipv4(Addr) -> + case is_ipv4_address(Addr) of + true -> ipv4; + false -> classify_host_regname(Addr) + end. + +classify_host_regname([]) -> regname; +classify_host_regname([H|T]) -> + case is_reg_name(H) of + true -> classify_host_regname(T); + false -> other + end. + +is_ipv4_address(Addr) -> + case inet:parse_ipv4strict_address(Addr) of + {ok, _} -> true; + {error, _} -> false + end. + +is_ipv6_address(Addr) -> + case inet:parse_ipv6strict_address(Addr) of + {ok, _} -> true; + {error, _} -> false + end. + +bracket_ipv6(Addr) when is_binary(Addr) -> + concat(<<$[,Addr/binary>>,<<$]>>); +bracket_ipv6(Addr) when is_list(Addr) -> + [$[|Addr] ++ "]". + + +%%------------------------------------------------------------------------- +%% Helper funtions for recompose +%%------------------------------------------------------------------------- + +%%------------------------------------------------------------------------- +%% Checks if input Map has valid combination of fields that can be +%% recomposed into a URI. +%% +%% The implementation is based on a decision tree that fulfills the +%% following rules: +%% - 'path' shall always be present in the input map +%% URI = scheme ":" hier-part [ "?" query ] [ "#" fragment ] +%% hier-part = "//" authority path-abempty +%% / path-absolute +%% / path-rootless +%% / path-empty +%% - 'host' shall be present in the input map when 'path' starts with +%% two slashes ("//") +%% path = path-abempty ; begins with "/" or is empty +%% / path-absolute ; begins with "/" but not "//" +%% / path-noscheme ; begins with a non-colon segment +%% / path-rootless ; begins with a segment +%% / path-empty ; zero characters +%% path-abempty = *( "/" segment ) +%% segment = *pchar +%% - 'host' shall be present if userinfo or port is present in input map +%% authority = [ userinfo "@" ] host [ ":" port ] +%% - All fields shall be valid (scheme, userinfo, host, port, path, query +%% or fragment). +%%------------------------------------------------------------------------- +is_valid_map(#{path := Path} = Map) -> + ((starts_with_two_slash(Path) andalso is_valid_map_host(Map)) + orelse + (maps:is_key(userinfo, Map) andalso is_valid_map_host(Map)) + orelse + (maps:is_key(port, Map) andalso is_valid_map_host(Map)) + orelse + all_fields_valid(Map)); +is_valid_map(#{}) -> + false. + + +is_valid_map_host(Map) -> + maps:is_key(host, Map) andalso all_fields_valid(Map). + + +all_fields_valid(Map) -> + Fun = fun(scheme, _, Acc) -> Acc; + (userinfo, _, Acc) -> Acc; + (host, _, Acc) -> Acc; + (port, _, Acc) -> Acc; + (path, _, Acc) -> Acc; + (query, _, Acc) -> Acc; + (fragment, _, Acc) -> Acc; + (_, _, _) -> false + end, + maps:fold(Fun, true, Map). + + +starts_with_two_slash([$/,$/|_]) -> + true; +starts_with_two_slash(?STRING_REST("//", _)) -> + true; +starts_with_two_slash(_) -> false. + + +update_scheme(#{scheme := Scheme}, _) -> + add_colon_postfix(encode_scheme(Scheme)); +update_scheme(#{}, _) -> + empty. + + +update_userinfo(#{userinfo := Userinfo}, empty) -> + add_auth_prefix(encode_userinfo(Userinfo)); +update_userinfo(#{userinfo := Userinfo}, URI) -> + concat(URI,add_auth_prefix(encode_userinfo(Userinfo))); +update_userinfo(#{}, empty) -> + empty; +update_userinfo(#{}, URI) -> + URI. + + +update_host(#{host := Host}, empty) -> + add_auth_prefix(encode_host(Host)); +update_host(#{host := Host} = Map, URI) -> + concat(URI,add_host_prefix(Map, encode_host(Host))); +update_host(#{}, empty) -> + empty; +update_host(#{}, URI) -> + URI. + + +%% URI cannot be empty for ports. E.g. ":8080" is not a valid URI +update_port(#{port := undefined}, URI) -> + concat(URI, <<":">>); +update_port(#{port := Port}, URI) -> + concat(URI,add_colon(encode_port(Port))); +update_port(#{}, URI) -> + URI. + + +update_path(#{path := Path}, empty) -> + encode_path(Path); +update_path(#{path := Path}, URI) -> + concat(URI,encode_path(Path)); +update_path(#{}, empty) -> + empty; +update_path(#{}, URI) -> + URI. + + +update_query(#{query := Query}, empty) -> + encode_query(Query); +update_query(#{query := Query}, URI) -> + concat(URI,add_question_mark(encode_query(Query))); +update_query(#{}, empty) -> + empty; +update_query(#{}, URI) -> + URI. + + +update_fragment(#{fragment := Fragment}, empty) -> + add_hashmark(encode_fragment(Fragment)); +update_fragment(#{fragment := Fragment}, URI) -> + concat(URI,add_hashmark(encode_fragment(Fragment))); +update_fragment(#{}, empty) -> + ""; +update_fragment(#{}, URI) -> + URI. + +%%------------------------------------------------------------------------- +%% Concatenates its arguments that can be lists and binaries. +%% The result is a list if at least one of its argument is a list and +%% binary otherwise. +%%------------------------------------------------------------------------- +concat(A, B) when is_binary(A), is_binary(B) -> + <<A/binary, B/binary>>; +concat(A, B) when is_binary(A), is_list(B) -> + unicode:characters_to_list(A) ++ B; +concat(A, B) when is_list(A) -> + A ++ maybe_to_list(B). + +add_hashmark(Comp) when is_binary(Comp) -> + <<$#, Comp/binary>>; +add_hashmark(Comp) when is_list(Comp) -> + [$#|Comp]. + +add_question_mark(Comp) when is_binary(Comp) -> + <<$?, Comp/binary>>; +add_question_mark(Comp) when is_list(Comp) -> + [$?|Comp]. + +add_colon(Comp) when is_binary(Comp) -> + <<$:, Comp/binary>>. + +add_colon_postfix(Comp) when is_binary(Comp) -> + <<Comp/binary,$:>>; +add_colon_postfix(Comp) when is_list(Comp) -> + Comp ++ ":". + +add_auth_prefix(Comp) when is_binary(Comp) -> + <<"//", Comp/binary>>; +add_auth_prefix(Comp) when is_list(Comp) -> + [$/,$/|Comp]. + +add_host_prefix(#{userinfo := _}, Host) when is_binary(Host) -> + <<$@,Host/binary>>; +add_host_prefix(#{}, Host) when is_binary(Host) -> + <<"//",Host/binary>>; +add_host_prefix(#{userinfo := _}, Host) when is_list(Host) -> + [$@|Host]; +add_host_prefix(#{}, Host) when is_list(Host) -> + [$/,$/|Host]. + +maybe_to_list(Comp) when is_binary(Comp) -> unicode:characters_to_list(Comp); +maybe_to_list(Comp) -> Comp. + +encode_port(Port) -> + integer_to_binary(Port). + +%%------------------------------------------------------------------------- +%% Helper functions for transcode +%%------------------------------------------------------------------------- + +%%------------------------------------------------------------------------- +%% uri_string:transcode(<<"x%00%00%00%F6"/utf32>>). +%% 1. Convert (transcode/2) input to list form (list of unicode codepoints) +%% "x%00%00%00%F6" +%% 2. Accumulate characters until percent-encoded segment (transcode/4). +%% Acc = "x" +%% 3. Convert percent-encoded triplets to binary form (transcode_pct/4) +%% <<0,0,0,246>> +%% 4. Transcode in-encoded binary to out-encoding (utf32 -> utf8): +%% <<195,182>> +%% 5. Percent-encode out-encoded binary: +%% <<"%C3%B6"/utf8>> = <<37,67,51,37,66,54>> +%% 6. Convert binary to list form, reverse it and append the accumulator +%% "6B%3C%" + "x" +%% 7. Reverse Acc and return it +%%------------------------------------------------------------------------- +transcode([$%,_C0,_C1|_Rest] = L, Acc, InEnc, OutEnc) -> + transcode_pct(L, Acc, <<>>, InEnc, OutEnc); +transcode([_C|_Rest] = L, Acc, InEnc, OutEnc) -> + transcode(L, Acc, [], InEnc, OutEnc). +%% +transcode([$%,_C0,_C1|_Rest] = L, Acc, List, InEncoding, OutEncoding) -> + transcode_pct(L, List ++ Acc, <<>>, InEncoding, OutEncoding); +transcode([C|Rest], Acc, List, InEncoding, OutEncoding) -> + transcode(Rest, Acc, [C|List], InEncoding, OutEncoding); +transcode([], Acc, List, _InEncoding, _OutEncoding) -> + lists:reverse(List ++ Acc). + + +%% Transcode percent-encoded segment +transcode_pct([$%,C0,C1|Rest] = L, Acc, B, InEncoding, OutEncoding) -> + case is_hex_digit(C0) andalso is_hex_digit(C1) of + true -> + Int = ?HEX2DEC(C0)*16+?HEX2DEC(C1), + transcode_pct(Rest, Acc, <<B/binary, Int>>, InEncoding, OutEncoding); + false -> throw({error, invalid_percent_encoding,L}) + end; +transcode_pct([_C|_Rest] = L, Acc, B, InEncoding, OutEncoding) -> + OutBinary = convert_to_binary(B, InEncoding, OutEncoding), + PctEncUtf8 = percent_encode_segment(OutBinary), + Out = lists:reverse(convert_to_list(PctEncUtf8, utf8)), + transcode(L, Out ++ Acc, [], InEncoding, OutEncoding); +transcode_pct([], Acc, B, InEncoding, OutEncoding) -> + OutBinary = convert_to_binary(B, InEncoding, OutEncoding), + PctEncUtf8 = percent_encode_segment(OutBinary), + Out = convert_to_list(PctEncUtf8, utf8), + lists:reverse(Acc) ++ Out. + + +%% Convert to binary +convert_to_binary(Binary, InEncoding, OutEncoding) -> + case unicode:characters_to_binary(Binary, InEncoding, OutEncoding) of + {error, _List, RestData} -> + throw({error, invalid_input, RestData}); + {incomplete, _List, RestData} -> + throw({error, invalid_input, RestData}); + Result -> + Result + end. + + +%% Convert to list +convert_to_list(Binary, InEncoding) -> + case unicode:characters_to_list(Binary, InEncoding) of + {error, _List, RestData} -> + throw({error, invalid_input, RestData}); + {incomplete, _List, RestData} -> + throw({error, invalid_input, RestData}); + Result -> + Result + end. + + +%% Flatten input list +flatten_list([], _) -> + []; +flatten_list(L, InEnc) -> + flatten_list(L, InEnc, []). +%% +flatten_list([H|T], InEnc, Acc) when is_binary(H) -> + L = convert_to_list(H, InEnc), + flatten_list(T, InEnc, lists:reverse(L) ++ Acc); +flatten_list([H|T], InEnc, Acc) when is_list(H) -> + flatten_list(H ++ T, InEnc, Acc); +flatten_list([H|T], InEnc, Acc) -> + flatten_list(T, InEnc, [H|Acc]); +flatten_list([], _InEnc, Acc) -> + lists:reverse(Acc); +flatten_list(Arg, _, _) -> + throw({error, invalid_input, Arg}). + + +percent_encode_segment(Segment) -> + percent_encode_binary(Segment, <<>>). + + +%%------------------------------------------------------------------------- +%% Helper functions for compose_query +%%------------------------------------------------------------------------- + +%% Returns separator to be used between key-value pairs +get_separator(L) when length(L) =:= 0 -> + <<>>; +get_separator(_L) -> + <<"&">>. + + +%% HTML 5.2 - 4.10.21.6 URL-encoded form data - WHATWG URL (10 Jan 2018) - UTF-8 +%% HTML 5.0 - 4.10.22.6 URL-encoded form data - encoding (non UTF-8) +form_urlencode(Cs, [{encoding, latin1}]) when is_list(Cs) -> + B = convert_to_binary(Cs, utf8, utf8), + html5_byte_encode(base10_encode(B)); +form_urlencode(Cs, [{encoding, latin1}]) when is_binary(Cs) -> + html5_byte_encode(base10_encode(Cs)); +form_urlencode(Cs, [{encoding, Encoding}]) + when is_list(Cs), Encoding =:= utf8; Encoding =:= unicode -> + B = convert_to_binary(Cs, utf8, Encoding), + html5_byte_encode(B); +form_urlencode(Cs, [{encoding, Encoding}]) + when is_binary(Cs), Encoding =:= utf8; Encoding =:= unicode -> + html5_byte_encode(Cs); +form_urlencode(Cs, [{encoding, Encoding}]) when is_list(Cs); is_binary(Cs) -> + throw({error,invalid_encoding, Encoding}); +form_urlencode(Cs, _) -> + throw({error,invalid_input, Cs}). + + +%% For each character in the entry's name and value that cannot be expressed using +%% the selected character encoding, replace the character by a string consisting of +%% a U+0026 AMPERSAND character (&), a "#" (U+0023) character, one or more ASCII +%% digits representing the Unicode code point of the character in base ten, and +%% finally a ";" (U+003B) character. +base10_encode(Cs) -> + base10_encode(Cs, <<>>). +%% +base10_encode(<<>>, Acc) -> + Acc; +base10_encode(<<H/utf8,T/binary>>, Acc) when H > 255 -> + Base10 = convert_to_binary(integer_to_list(H,10), utf8, utf8), + base10_encode(T, <<Acc/binary,"&#",Base10/binary,$;>>); +base10_encode(<<H/utf8,T/binary>>, Acc) -> + base10_encode(T, <<Acc/binary,H>>). + + +html5_byte_encode(B) -> + html5_byte_encode(B, <<>>). +%% +html5_byte_encode(<<>>, Acc) -> + Acc; +html5_byte_encode(<<$ ,T/binary>>, Acc) -> + html5_byte_encode(T, <<Acc/binary,$+>>); +html5_byte_encode(<<H,T/binary>>, Acc) -> + case is_url_char(H) of + true -> + html5_byte_encode(T, <<Acc/binary,H>>); + false -> + <<A:4,B:4>> = <<H>>, + html5_byte_encode(T, <<Acc/binary,$%,(?DEC2HEX(A)),(?DEC2HEX(B))>>) + end; +html5_byte_encode(H, _Acc) -> + throw({error,invalid_input, H}). + + +%% Return true if input char can appear in form-urlencoded string +%% Allowed chararacters: +%% 0x2A, 0x2D, 0x2E, 0x30 to 0x39, 0x41 to 0x5A, +%% 0x5F, 0x61 to 0x7A +is_url_char(C) + when C =:= 16#2A; C =:= 16#2D; + C =:= 16#2E; C =:= 16#5F; + 16#30 =< C, C =< 16#39; + 16#41 =< C, C =< 16#5A; + 16#61 =< C, C =< 16#7A -> true; +is_url_char(_) -> false. + + +%%------------------------------------------------------------------------- +%% Helper functions for dissect_query +%%------------------------------------------------------------------------- +dissect_query_key(<<$=,T/binary>>, IsList, Acc, Key, Value) -> + dissect_query_value(T, IsList, Acc, Key, Value); +dissect_query_key(<<"&#",T/binary>>, IsList, Acc, Key, Value) -> + dissect_query_key(T, IsList, Acc, <<Key/binary,"&#">>, Value); +dissect_query_key(<<$&,_T/binary>>, _IsList, _Acc, _Key, _Value) -> + throw({error, missing_value, "&"}); +dissect_query_key(<<H,T/binary>>, IsList, Acc, Key, Value) -> + dissect_query_key(T, IsList, Acc, <<Key/binary,H>>, Value); +dissect_query_key(B, _, _, _, _) -> + throw({error, missing_value, B}). + + +dissect_query_value(<<$&,T/binary>>, IsList, Acc, Key, Value) -> + K = form_urldecode(IsList, Key), + V = form_urldecode(IsList, Value), + dissect_query_key(T, IsList, [{K,V}|Acc], <<>>, <<>>); +dissect_query_value(<<H,T/binary>>, IsList, Acc, Key, Value) -> + dissect_query_value(T, IsList, Acc, Key, <<Value/binary,H>>); +dissect_query_value(<<>>, IsList, Acc, Key, Value) -> + K = form_urldecode(IsList, Key), + V = form_urldecode(IsList, Value), + lists:reverse([{K,V}|Acc]). + + +%% HTML 5.2 - 4.10.21.6 URL-encoded form data - WHATWG URL (10 Jan 2018) - UTF-8 +%% HTML 5.0 - 4.10.22.6 URL-encoded form data - decoding (non UTF-8) +form_urldecode(true, B) -> + Result = base10_decode(form_urldecode(B, <<>>)), + convert_to_list(Result, utf8); +form_urldecode(false, B) -> + base10_decode(form_urldecode(B, <<>>)); +form_urldecode(<<>>, Acc) -> + Acc; +form_urldecode(<<$+,T/binary>>, Acc) -> + form_urldecode(T, <<Acc/binary,$ >>); +form_urldecode(<<$%,C0,C1,T/binary>>, Acc) -> + case is_hex_digit(C0) andalso is_hex_digit(C1) of + true -> + V = ?HEX2DEC(C0)*16+?HEX2DEC(C1), + form_urldecode(T, <<Acc/binary, V>>); + false -> + L = convert_to_list(<<$%,C0,C1,T/binary>>, utf8), + throw({error, invalid_percent_encoding, L}) + end; +form_urldecode(<<H/utf8,T/binary>>, Acc) -> + form_urldecode(T, <<Acc/binary,H/utf8>>); +form_urldecode(<<H,_/binary>>, _Acc) -> + throw({error, invalid_character, [H]}). + +base10_decode(Cs) -> + base10_decode(Cs, <<>>). +% +base10_decode(<<>>, Acc) -> + Acc; +base10_decode(<<"&#",T/binary>>, Acc) -> + base10_decode_unicode(T, Acc); +base10_decode(<<H/utf8,T/binary>>, Acc) -> + base10_decode(T,<<Acc/binary,H/utf8>>); +base10_decode(<<H,_/binary>>, _) -> + throw({error, invalid_input, [H]}). + + +base10_decode_unicode(B, Acc) -> + base10_decode_unicode(B, 0, Acc). +%% +base10_decode_unicode(<<H/utf8,T/binary>>, Codepoint, Acc) when $0 =< H, H =< $9 -> + Res = Codepoint * 10 + (H - $0), + base10_decode_unicode(T, Res, Acc); +base10_decode_unicode(<<$;,T/binary>>, Codepoint, Acc) -> + base10_decode(T, <<Acc/binary,Codepoint/utf8>>); +base10_decode_unicode(<<H,_/binary>>, _, _) -> + throw({error, invalid_input, [H]}). + + +%%------------------------------------------------------------------------- +%% Helper functions for normalize +%%------------------------------------------------------------------------- + +normalize_map(URIMap) -> + normalize_path_segment( + normalize_scheme_based( + normalize_percent_encoding( + normalize_case(URIMap)))). + + +%% 6.2.2.1. Case Normalization +normalize_case(#{scheme := Scheme, host := Host} = Map) -> + Map#{scheme => to_lower(Scheme), + host => to_lower(Host)}; +normalize_case(#{host := Host} = Map) -> + Map#{host => to_lower(Host)}; +normalize_case(#{scheme := Scheme} = Map) -> + Map#{scheme => to_lower(Scheme)}; +normalize_case(#{} = Map) -> + Map. + + +%% 6.2.2.2. Percent-Encoding Normalization +normalize_percent_encoding(Map) -> + Fun = fun (K,V) when K =:= userinfo; K =:= host; K =:= path; + K =:= query; K =:= fragment -> + decode(V); + %% Handle port and scheme + (_,V) -> + V + end, + maps:map(Fun, Map). + + +to_lower(Cs) when is_list(Cs) -> + B = convert_to_binary(Cs, utf8, utf8), + convert_to_list(to_lower(B), utf8); +to_lower(Cs) when is_binary(Cs) -> + to_lower(Cs, <<>>). +%% +to_lower(<<C,Cs/binary>>, Acc) when $A =< C, C =< $Z -> + to_lower(Cs, <<Acc/binary,(C + 32)>>); +to_lower(<<C,Cs/binary>>, Acc) -> + to_lower(Cs, <<Acc/binary,C>>); +to_lower(<<>>, Acc) -> + Acc. + + +%% 6.2.2.3. Path Segment Normalization +%% 5.2.4. Remove Dot Segments +normalize_path_segment(Map) -> + Path = maps:get(path, Map, undefined), + Map#{path => remove_dot_segments(Path)}. + + +remove_dot_segments(Path) when is_binary(Path) -> + remove_dot_segments(Path, <<>>); +remove_dot_segments(Path) when is_list(Path) -> + B = convert_to_binary(Path, utf8, utf8), + B1 = remove_dot_segments(B, <<>>), + convert_to_list(B1, utf8). +%% +remove_dot_segments(<<>>, Output) -> + Output; +remove_dot_segments(<<"../",T/binary>>, Output) -> + remove_dot_segments(T, Output); +remove_dot_segments(<<"./",T/binary>>, Output) -> + remove_dot_segments(T, Output); +remove_dot_segments(<<"/./",T/binary>>, Output) -> + remove_dot_segments(<<$/,T/binary>>, Output); +remove_dot_segments(<<"/.">>, Output) -> + remove_dot_segments(<<$/>>, Output); +remove_dot_segments(<<"/../",T/binary>>, Output) -> + Out1 = remove_last_segment(Output), + remove_dot_segments(<<$/,T/binary>>, Out1); +remove_dot_segments(<<"/..">>, Output) -> + Out1 = remove_last_segment(Output), + remove_dot_segments(<<$/>>, Out1); +remove_dot_segments(<<$.>>, Output) -> + remove_dot_segments(<<>>, Output); +remove_dot_segments(<<"..">>, Output) -> + remove_dot_segments(<<>>, Output); +remove_dot_segments(Input, Output) -> + {First, Rest} = first_path_segment(Input), + remove_dot_segments(Rest, <<Output/binary,First/binary>>). + + +first_path_segment(Input) -> + F = first_path_segment(Input, <<>>), + split_binary(Input, byte_size(F)). +%% +first_path_segment(<<$/,T/binary>>, Acc) -> + first_path_segment_end(<<T/binary>>, <<Acc/binary,$/>>); +first_path_segment(<<C,T/binary>>, Acc) -> + first_path_segment_end(<<T/binary>>, <<Acc/binary,C>>). + + +first_path_segment_end(<<>>, Acc) -> + Acc; +first_path_segment_end(<<$/,_/binary>>, Acc) -> + Acc; +first_path_segment_end(<<C,T/binary>>, Acc) -> + first_path_segment_end(<<T/binary>>, <<Acc/binary,C>>). + + +remove_last_segment(<<>>) -> + <<>>; +remove_last_segment(B) -> + {Init, Last} = split_binary(B, byte_size(B) - 1), + case Last of + <<$/>> -> + Init; + _Char -> + remove_last_segment(Init) + end. + + +%% RFC 3986, 6.2.3. Scheme-Based Normalization +normalize_scheme_based(Map) -> + Scheme = maps:get(scheme, Map, undefined), + Port = maps:get(port, Map, undefined), + Path= maps:get(path, Map, undefined), + normalize_scheme_based(Map, Scheme, Port, Path). +%% +normalize_scheme_based(Map, Scheme, Port, Path) + when Scheme =:= "http"; Scheme =:= <<"http">> -> + normalize_http(Map, Port, Path); +normalize_scheme_based(Map, Scheme, Port, Path) + when Scheme =:= "https"; Scheme =:= <<"https">> -> + normalize_https(Map, Port, Path); +normalize_scheme_based(Map, Scheme, Port, _Path) + when Scheme =:= "ftp"; Scheme =:= <<"ftp">> -> + normalize_ftp(Map, Port); +normalize_scheme_based(Map, Scheme, Port, _Path) + when Scheme =:= "ssh"; Scheme =:= <<"ssh">> -> + normalize_ssh_sftp(Map, Port); +normalize_scheme_based(Map, Scheme, Port, _Path) + when Scheme =:= "sftp"; Scheme =:= <<"sftp">> -> + normalize_ssh_sftp(Map, Port); +normalize_scheme_based(Map, Scheme, Port, _Path) + when Scheme =:= "tftp"; Scheme =:= <<"tftp">> -> + normalize_tftp(Map, Port); +normalize_scheme_based(Map, _, _, _) -> + Map. + + +normalize_http(Map, Port, Path) -> + M1 = normalize_port(Map, Port, 80), + normalize_http_path(M1, Path). + + +normalize_https(Map, Port, Path) -> + M1 = normalize_port(Map, Port, 443), + normalize_http_path(M1, Path). + + +normalize_ftp(Map, Port) -> + normalize_port(Map, Port, 21). + + +normalize_ssh_sftp(Map, Port) -> + normalize_port(Map, Port, 22). + + +normalize_tftp(Map, Port) -> + normalize_port(Map, Port, 69). + + +normalize_port(Map, Port, Default) -> + case Port of + Default -> + maps:remove(port, Map); + _Else -> + Map + end. + + +normalize_http_path(Map, Path) -> + case Path of + "" -> + Map#{path => "/"}; + <<>> -> + Map#{path => <<"/">>}; + _Else -> + Map + end. 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 f8ba6f18e9..a922bf3fbe 100644 --- a/lib/stdlib/src/zip.erl +++ b/lib/stdlib/src/zip.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2006-2016. All Rights Reserved. +%% Copyright Ericsson AB 2006-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. @@ -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,19 @@ 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 -> + zlib:close(Z), + Output({close, F}, Out0), + erlang:raise(C, R, Stk) + end. + %% List zip directory contents %% @@ -1378,12 +1377,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 +1397,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 +1408,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 +1429,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,20 +1565,6 @@ 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) pwrite_binary(B, Pos, Bin) when byte_size(B) =:= Pos -> |