aboutsummaryrefslogtreecommitdiffstats
path: root/lib/stdlib/src
diff options
context:
space:
mode:
Diffstat (limited to 'lib/stdlib/src')
-rw-r--r--lib/stdlib/src/Makefile13
-rw-r--r--lib/stdlib/src/array.erl16
-rw-r--r--lib/stdlib/src/base64.erl69
-rw-r--r--lib/stdlib/src/beam_lib.erl147
-rw-r--r--lib/stdlib/src/binary.erl4
-rw-r--r--lib/stdlib/src/c.erl302
-rw-r--r--lib/stdlib/src/dets.erl489
-rw-r--r--lib/stdlib/src/dets.hrl162
-rw-r--r--lib/stdlib/src/dets_utils.erl26
-rw-r--r--lib/stdlib/src/dets_v8.erl1594
-rw-r--r--lib/stdlib/src/dets_v9.erl112
-rw-r--r--lib/stdlib/src/dict.erl23
-rw-r--r--lib/stdlib/src/edlin.erl132
-rw-r--r--lib/stdlib/src/epp.erl28
-rw-r--r--lib/stdlib/src/erl_abstract_code.erl28
-rw-r--r--lib/stdlib/src/erl_anno.erl8
-rw-r--r--lib/stdlib/src/erl_compile.erl8
-rw-r--r--lib/stdlib/src/erl_expand_records.erl113
-rw-r--r--lib/stdlib/src/erl_internal.erl124
-rw-r--r--lib/stdlib/src/erl_lint.erl461
-rw-r--r--lib/stdlib/src/erl_parse.yrl109
-rw-r--r--lib/stdlib/src/erl_pp.erl133
-rw-r--r--lib/stdlib/src/erl_tar.erl2582
-rw-r--r--lib/stdlib/src/erl_tar.hrl396
-rw-r--r--lib/stdlib/src/error_logger_file_h.erl71
-rw-r--r--lib/stdlib/src/error_logger_tty_h.erl72
-rw-r--r--lib/stdlib/src/escript.erl15
-rw-r--r--lib/stdlib/src/ets.erl50
-rw-r--r--lib/stdlib/src/eval_bits.erl14
-rw-r--r--lib/stdlib/src/filelib.erl124
-rw-r--r--lib/stdlib/src/filename.erl108
-rw-r--r--lib/stdlib/src/gb_sets.erl7
-rw-r--r--lib/stdlib/src/gb_trees.erl52
-rw-r--r--lib/stdlib/src/gen.erl12
-rw-r--r--lib/stdlib/src/gen_event.erl170
-rw-r--r--lib/stdlib/src/gen_fsm.erl150
-rw-r--r--lib/stdlib/src/gen_server.erl338
-rw-r--r--lib/stdlib/src/gen_statem.erl233
-rw-r--r--lib/stdlib/src/io_lib.erl228
-rw-r--r--lib/stdlib/src/io_lib_format.erl39
-rw-r--r--lib/stdlib/src/io_lib_fread.erl11
-rw-r--r--lib/stdlib/src/io_lib_pretty.erl48
-rw-r--r--lib/stdlib/src/lib.erl292
-rw-r--r--lib/stdlib/src/math.erl19
-rw-r--r--lib/stdlib/src/ms_transform.erl62
-rw-r--r--lib/stdlib/src/orddict.erl21
-rw-r--r--lib/stdlib/src/otp_internal.erl274
-rw-r--r--lib/stdlib/src/proc_lib.erl160
-rw-r--r--lib/stdlib/src/proplists.erl17
-rw-r--r--lib/stdlib/src/qlc.erl51
-rw-r--r--lib/stdlib/src/qlc_pt.erl59
-rw-r--r--lib/stdlib/src/rand.erl645
-rw-r--r--lib/stdlib/src/re.erl9
-rw-r--r--lib/stdlib/src/sets.erl66
-rw-r--r--lib/stdlib/src/shell.erl64
-rw-r--r--lib/stdlib/src/shell_default.erl5
-rw-r--r--lib/stdlib/src/sofs.erl357
-rw-r--r--lib/stdlib/src/stdlib.app.src7
-rw-r--r--lib/stdlib/src/stdlib.appup.src6
-rw-r--r--lib/stdlib/src/string.erl1347
-rw-r--r--lib/stdlib/src/sys.erl6
-rw-r--r--lib/stdlib/src/timer.erl6
-rw-r--r--lib/stdlib/src/unicode.erl341
63 files changed, 7848 insertions, 4787 deletions
diff --git a/lib/stdlib/src/Makefile b/lib/stdlib/src/Makefile
index 302834f9d0..bf836203ec 100644
--- a/lib/stdlib/src/Makefile
+++ b/lib/stdlib/src/Makefile
@@ -1,7 +1,7 @@
#
# %CopyrightBegin%
#
-# Copyright Ericsson AB 1996-2016. All Rights Reserved.
+# Copyright Ericsson AB 1996-2017. All Rights Reserved.
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
@@ -51,7 +51,6 @@ MODULES= \
dets_server \
dets_sup \
dets_utils \
- dets_v8 \
dets_v9 \
dict \
digraph \
@@ -59,6 +58,7 @@ MODULES= \
edlin \
edlin_expand \
epp \
+ erl_abstract_code \
erl_anno \
erl_bits \
erl_compile \
@@ -120,6 +120,7 @@ MODULES= \
sys \
timer \
unicode \
+ unicode_util \
win32reg \
zip
@@ -131,7 +132,7 @@ HRL_FILES= \
../include/qlc.hrl \
../include/zip.hrl
-INTERNAL_HRL_FILES= dets.hrl
+INTERNAL_HRL_FILES= dets.hrl erl_tar.hrl
ERL_FILES= $(MODULES:%=%.erl)
@@ -201,6 +202,9 @@ $(APP_TARGET): $(APP_SRC) ../vsn.mk
$(APPUP_TARGET): $(APPUP_SRC) ../vsn.mk
$(vsn_verbose)sed -e 's;%VSN%;$(VSN);' $< > $@
+unicode_util.erl: ../uc_spec/*
+ escript ../uc_spec/gen_unicode_mod.escript
+
# ----------------------------------------------------
# Release Target
# ----------------------------------------------------
@@ -225,12 +229,11 @@ $(EBIN)/beam_lib.beam: ../include/erl_compile.hrl ../../kernel/include/file.hrl
$(EBIN)/dets.beam: dets.hrl ../../kernel/include/file.hrl
$(EBIN)/dets_server.beam: dets.hrl
$(EBIN)/dets_utils.beam: dets.hrl
-$(EBIN)/dets_v8.beam: dets.hrl
$(EBIN)/dets_v9.beam: dets.hrl
$(EBIN)/erl_bits.beam: ../include/erl_bits.hrl
$(EBIN)/erl_compile.beam: ../include/erl_compile.hrl ../../kernel/include/file.hrl
$(EBIN)/erl_lint.beam: ../include/erl_bits.hrl
-$(EBIN)/erl_tar.beam: ../../kernel/include/file.hrl
+$(EBIN)/erl_tar.beam: ../../kernel/include/file.hrl erl_tar.hrl
$(EBIN)/file_sorter.beam: ../../kernel/include/file.hrl
$(EBIN)/filelib.beam: ../../kernel/include/file.hrl
$(EBIN)/filename.beam: ../../kernel/include/file.hrl
diff --git a/lib/stdlib/src/array.erl b/lib/stdlib/src/array.erl
index d5757dda5b..a237eaa489 100644
--- a/lib/stdlib/src/array.erl
+++ b/lib/stdlib/src/array.erl
@@ -1,8 +1,3 @@
-%%
-%% %CopyrightBegin%
-%%
-%% Copyright Ericsson AB 2007-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
@@ -14,13 +9,12 @@
%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
%% See the License for the specific language governing permissions and
%% limitations under the License.
-%%
-%% %CopyrightEnd%
%%
-%% @author Richard Carlsson <[email protected]>
+%% Copyright (C) 2006-2016 Richard Carlsson and Ericsson AB
+%%
+%% @author Richard Carlsson <[email protected]>
%% @author Dan Gudmundsson <[email protected]>
-%% @version 1.0
-
+%%
%% @doc Functional, extendible arrays. Arrays can have fixed size, or
%% can grow automatically as needed. A default value is used for entries
%% that have not been explicitly set.
@@ -1609,7 +1603,7 @@ foldl_2(I, E, A, Ix, F, D, N, R, S) ->
Ix + S, F, D, N, R, S).
-spec foldl_3(pos_integer(), _, A, array_indx(),
- fun((array_indx, _, A) -> B), integer()) -> B.
+ fun((array_indx(), _, A) -> B), integer()) -> B.
foldl_3(I, E, A, Ix, F, N) when I =< N ->
foldl_3(I+1, E, F(Ix, element(I, E), A), Ix+1, F, N);
diff --git a/lib/stdlib/src/base64.erl b/lib/stdlib/src/base64.erl
index bf259e6691..5885745fb1 100644
--- a/lib/stdlib/src/base64.erl
+++ b/lib/stdlib/src/base64.erl
@@ -1,7 +1,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 2007-2016. All Rights Reserved.
+%% Copyright Ericsson AB 2007-2017. All Rights Reserved.
%%
%% Licensed under the Apache License, Version 2.0 (the "License");
%% you may not use this file except in compliance with the License.
@@ -219,38 +219,49 @@ mime_decode_binary(Result, <<0:8,T/bits>>) ->
mime_decode_binary(Result, T);
mime_decode_binary(Result0, <<C:8,T/bits>>) ->
case element(C, ?DECODE_MAP) of
- Bits when is_integer(Bits) ->
- mime_decode_binary(<<Result0/bits,Bits:6>>, T);
- eq ->
- case tail_contains_more(T, false) of
- {<<>>, Eq} ->
- %% No more valid data.
- case bit_size(Result0) rem 8 of
- 0 ->
- %% '====' is not uncommon.
- Result0;
- 4 when Eq ->
- %% enforce at least one more '=' only ignoring illegals and spacing
- Split = byte_size(Result0) - 1,
- <<Result:Split/bytes,_:4>> = Result0,
- Result;
- 2 ->
- %% remove 2 bits
- Split = byte_size(Result0) - 1,
- <<Result:Split/bytes,_:2>> = Result0,
- Result
- end;
- {More, _} ->
- %% More valid data, skip the eq as invalid
- mime_decode_binary(Result0, More)
- end;
- _ ->
- mime_decode_binary(Result0, T)
+ Bits when is_integer(Bits) ->
+ mime_decode_binary(<<Result0/bits,Bits:6>>, T);
+ eq ->
+ mime_decode_binary_after_eq(Result0, T, false);
+ _ ->
+ mime_decode_binary(Result0, T)
end;
-mime_decode_binary(Result, <<>>) ->
+mime_decode_binary(Result, _) ->
true = is_binary(Result),
Result.
+mime_decode_binary_after_eq(Result, <<0:8,T/bits>>, Eq) ->
+ mime_decode_binary_after_eq(Result, T, Eq);
+mime_decode_binary_after_eq(Result0, <<C:8,T/bits>>, Eq) ->
+ case element(C, ?DECODE_MAP) of
+ bad ->
+ mime_decode_binary_after_eq(Result0, T, Eq);
+ ws ->
+ mime_decode_binary_after_eq(Result0, T, Eq);
+ eq ->
+ mime_decode_binary_after_eq(Result0, T, true);
+ Bits when is_integer(Bits) ->
+ %% More valid data, skip the eq as invalid
+ mime_decode_binary(<<Result0/bits,Bits:6>>, T)
+ end;
+mime_decode_binary_after_eq(Result0, <<>>, Eq) ->
+ %% No more valid data.
+ case bit_size(Result0) rem 8 of
+ 0 ->
+ %% '====' is not uncommon.
+ Result0;
+ 4 when Eq ->
+ %% enforce at least one more '=' only ignoring illegals and spacing
+ Split = byte_size(Result0) - 1,
+ <<Result:Split/bytes,_:4>> = Result0,
+ Result;
+ 2 ->
+ %% remove 2 bits
+ Split = byte_size(Result0) - 1,
+ <<Result:Split/bytes,_:2>> = Result0,
+ Result
+ end.
+
decode([], A) -> A;
decode([$=,$=,C2,C1|Cs], A) ->
Bits2x6 = (b64d(C1) bsl 18) bor (b64d(C2) bsl 12),
diff --git a/lib/stdlib/src/beam_lib.erl b/lib/stdlib/src/beam_lib.erl
index d7ee5c1f5d..06c15fceda 100644
--- a/lib/stdlib/src/beam_lib.erl
+++ b/lib/stdlib/src/beam_lib.erl
@@ -1,7 +1,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 2000-2016. All Rights Reserved.
+%% Copyright Ericsson AB 2000-2017. All Rights Reserved.
%%
%% Licensed under the Apache License, Version 2.0 (the "License");
%% you may not use this file except in compliance with the License.
@@ -54,6 +54,7 @@
%%-------------------------------------------------------------------------
-type beam() :: module() | file:filename() | binary().
+-type debug_info() :: {DbgiVersion :: atom(), Backend :: module(), Data :: term()} | 'no_debug_info'.
-type forms() :: [erl_parse:abstract_form() | erl_parse:form_info()].
@@ -63,8 +64,9 @@
-type label() :: integer().
-type chunkid() :: nonempty_string(). % approximation of the strings below
-%% "Abst" | "Attr" | "CInf" | "ExpT" | "ImpT" | "LocT" | "Atom".
--type chunkname() :: 'abstract_code' | 'attributes' | 'compile_info'
+%% "Abst" | "Dbgi" | "Attr" | "CInf" | "ExpT" | "ImpT" | "LocT" | "Atom" | "AtU8".
+-type chunkname() :: 'abstract_code' | 'debug_info'
+ | 'attributes' | 'compile_info'
| 'exports' | 'labeled_exports'
| 'imports' | 'indexed_imports'
| 'locals' | 'labeled_locals'
@@ -77,6 +79,7 @@
-type chunkdata() :: {chunkid(), dataB()}
| {'abstract_code', abst_code()}
+ | {'debug_info', debug_info()}
| {'attributes', [attrib_entry()]}
| {'compile_info', [compinfo_entry()]}
| {'exports', [{atom(), arity()}]}
@@ -99,7 +102,7 @@
| {'file_error', file:filename(), file:posix()}.
-type chnk_rsn() :: {'unknown_chunk', file:filename(), atom()}
| {'key_missing_or_invalid', file:filename(),
- 'abstract_code'}
+ 'abstract_code' | 'debug_info'}
| info_rsn().
-type cmp_rsn() :: {'modules_different', module(), module()}
| {'chunks_different', chunkid()}
@@ -267,9 +270,9 @@ format_error({modules_different, Module1, Module2}) ->
[Module1, Module2]);
format_error({not_a_directory, Name}) ->
io_lib:format("~tp: Not a directory~n", [Name]);
-format_error({key_missing_or_invalid, File, abstract_code}) ->
- io_lib:format("~tp: Cannot decrypt abstract code because key is missing or invalid",
- [File]);
+format_error({key_missing_or_invalid, File, ChunkId}) ->
+ io_lib:format("~tp: Cannot decrypt ~ts because key is missing or invalid",
+ [File, ChunkId]);
format_error(badfun) ->
"not a fun or the fun has the wrong arity";
format_error(exists) ->
@@ -510,9 +513,9 @@ read_chunk_data(File0, ChunkNames) ->
read_chunk_data(File0, ChunkNames0, Options)
when is_atom(File0); is_list(File0); is_binary(File0) ->
File = beam_filename(File0),
- {ChunkIds, Names} = check_chunks(ChunkNames0, File, [], []),
+ {ChunkIds, Names, Optional} = check_chunks(ChunkNames0, File, [], [], []),
AllowMissingChunks = member(allow_missing_chunks, Options),
- {ok, Module, Chunks} = scan_beam(File, ChunkIds, AllowMissingChunks),
+ {ok, Module, Chunks} = scan_beam(File, ChunkIds, AllowMissingChunks, Optional),
AT = ets:new(beam_symbols, []),
T = {empty, AT},
try chunks_to_data(Names, Chunks, File, Chunks, Module, T, [])
@@ -520,25 +523,34 @@ read_chunk_data(File0, ChunkNames0, Options)
end.
%% -> {ok, list()} | throw(Error)
-check_chunks([ChunkName | Ids], File, IL, L) when is_atom(ChunkName) ->
+check_chunks([atoms | Ids], File, IL, L, O) ->
+ check_chunks(Ids, File, ["Atom", "AtU8" | IL],
+ [{atom_chunk, atoms} | L], ["Atom", "AtU8" | O]);
+check_chunks([abstract_code | Ids], File, IL, L, O) ->
+ check_chunks(Ids, File, ["Abst", "Dbgi" | IL],
+ [{abst_chunk, abstract_code} | L], ["Abst", "Dbgi" | O]);
+check_chunks([ChunkName | Ids], File, IL, L, O) when is_atom(ChunkName) ->
ChunkId = chunk_name_to_id(ChunkName, File),
- check_chunks(Ids, File, [ChunkId | IL], [{ChunkId, ChunkName} | L]);
-check_chunks([ChunkId | Ids], File, IL, L) -> % when is_list(ChunkId)
- check_chunks(Ids, File, [ChunkId | IL], [{ChunkId, ChunkId} | L]);
-check_chunks([], _File, IL, L) ->
- {lists:usort(IL), reverse(L)}.
+ check_chunks(Ids, File, [ChunkId | IL], [{ChunkId, ChunkName} | L], O);
+check_chunks([ChunkId | Ids], File, IL, L, O) -> % when is_list(ChunkId)
+ check_chunks(Ids, File, [ChunkId | IL], [{ChunkId, ChunkId} | L], O);
+check_chunks([], _File, IL, L, O) ->
+ {lists:usort(IL), reverse(L), O}.
%% -> {ok, Module, Data} | throw(Error)
scan_beam(File, What) ->
- scan_beam(File, What, false).
+ scan_beam(File, What, false, []).
%% -> {ok, Module, Data} | throw(Error)
-scan_beam(File, What0, AllowMissingChunks) ->
+scan_beam(File, What0, AllowMissingChunks, OptionalChunks) ->
case scan_beam1(File, What0) of
{missing, _FD, Mod, Data, What} when AllowMissingChunks ->
{ok, Mod, [{Id, missing_chunk} || Id <- What] ++ Data};
- {missing, FD, _Mod, _Data, What} ->
- error({missing_chunk, filename(FD), hd(What)});
+ {missing, FD, Mod, Data, What} ->
+ case What -- OptionalChunks of
+ [] -> {ok, Mod, Data};
+ [Missing | _] -> error({missing_chunk, filename(FD), Missing})
+ end;
R ->
R
end.
@@ -581,18 +593,23 @@ scan_beam(FD, Pos, What, Mod, Data) ->
error({invalid_beam_file, filename(FD), Pos})
end.
-get_data(Cs, "Atom"=Id, FD, Size, Pos, Pos2, _Mod, Data) ->
+get_atom_data(Cs, Id, FD, Size, Pos, Pos2, Data, Encoding) ->
NewCs = del_chunk(Id, Cs),
{NFD, Chunk} = get_chunk(Id, Pos, Size, FD),
<<_Num:32, Chunk2/binary>> = Chunk,
- {Module, _} = extract_atom(Chunk2),
+ {Module, _} = extract_atom(Chunk2, Encoding),
C = case Cs of
info ->
{Id, Pos, Size};
_ ->
{Id, Chunk}
end,
- scan_beam(NFD, Pos2, NewCs, Module, [C | Data]);
+ scan_beam(NFD, Pos2, NewCs, Module, [C | Data]).
+
+get_data(Cs, "Atom" = Id, FD, Size, Pos, Pos2, _Mod, Data) ->
+ get_atom_data(Cs, Id, FD, Size, Pos, Pos2, Data, latin1);
+get_data(Cs, "AtU8" = Id, FD, Size, Pos, Pos2, _Mod, Data) ->
+ get_atom_data(Cs, Id, FD, Size, Pos, Pos2, Data, utf8);
get_data(info, Id, FD, Size, Pos, Pos2, Mod, Data) ->
scan_beam(FD, Pos2, info, Mod, [{Id, Pos, Size} | Data]);
get_data(Chunks, Id, FD, Size, Pos, Pos2, Mod, Data) ->
@@ -624,6 +641,25 @@ get_chunk(Id, Pos, Size, FD) ->
{NFD, Chunk}
end.
+chunks_to_data([{atom_chunk, Name} | CNs], Chunks, File, Cs, Module, Atoms, L) ->
+ {NewAtoms, Ret} = chunk_to_data(Name, <<"">>, File, Cs, Atoms, Module),
+ chunks_to_data(CNs, Chunks, File, Cs, Module, NewAtoms, [Ret | L]);
+chunks_to_data([{abst_chunk, Name} | CNs], Chunks, File, Cs, Module, Atoms, L) ->
+ DbgiChunk = proplists:get_value("Dbgi", Chunks, <<"">>),
+ {NewAtoms, Ret} =
+ case catch chunk_to_data(debug_info, DbgiChunk, File, Cs, Atoms, Module) of
+ {DbgiAtoms, {debug_info, {debug_info_v1, Backend, Metadata}}} ->
+ case Backend:debug_info(erlang_v1, Module, Metadata, []) of
+ {ok, Code} -> {DbgiAtoms, {abstract_code, {raw_abstract_v1, Code}}};
+ {error, _} -> {DbgiAtoms, {abstract_code, no_abstract_code}}
+ end;
+ {error,beam_lib,{key_missing_or_invalid,Path,debug_info}} ->
+ error({key_missing_or_invalid,Path,abstract_code});
+ _ ->
+ AbstChunk = proplists:get_value("Abst", Chunks, <<"">>),
+ chunk_to_data(Name, AbstChunk, File, Cs, Atoms, Module)
+ end,
+ chunks_to_data(CNs, Chunks, File, Cs, Module, NewAtoms, [Ret | L]);
chunks_to_data([{Id, Name} | CNs], Chunks, File, Cs, Module, Atoms, L) ->
{_Id, Chunk} = lists:keyfind(Id, 1, Chunks),
{NewAtoms, Ret} = chunk_to_data(Name, Chunk, File, Cs, Atoms, Module),
@@ -646,13 +682,30 @@ chunk_to_data(compile_info=Id, Chunk, File, _Cs, AtomTable, _Mod) ->
error:badarg ->
error({invalid_chunk, File, chunk_name_to_id(Id, File)})
end;
+chunk_to_data(debug_info=Id, Chunk, File, _Cs, AtomTable, Mod) ->
+ case Chunk of
+ <<>> ->
+ {AtomTable, {Id, no_debug_info}};
+ <<0:8,N:8,Mode0:N/binary,Rest/binary>> ->
+ Mode = binary_to_atom(Mode0, utf8),
+ Term = decrypt_chunk(Mode, Mod, File, Id, Rest),
+ {AtomTable, {Id, Term}};
+ _ ->
+ case catch binary_to_term(Chunk) of
+ {'EXIT', _} ->
+ error({invalid_chunk, File, chunk_name_to_id(Id, File)});
+ Term ->
+ {AtomTable, {Id, Term}}
+ end
+ end;
chunk_to_data(abstract_code=Id, Chunk, File, _Cs, AtomTable, Mod) ->
case Chunk of
<<>> ->
{AtomTable, {Id, no_abstract_code}};
<<0:8,N:8,Mode0:N/binary,Rest/binary>> ->
- Mode = list_to_atom(binary_to_list(Mode0)),
- decrypt_abst(Mode, Mod, File, Id, AtomTable, Rest);
+ Mode = binary_to_atom(Mode0, utf8),
+ Term = decrypt_chunk(Mode, Mod, File, Id, Rest),
+ {AtomTable, {Id, anno_from_term(Term)}};
_ ->
case catch binary_to_term(Chunk) of
{'EXIT', _} ->
@@ -683,7 +736,6 @@ chunk_to_data(ChunkId, Chunk, _File,
_Cs, AtomTable, _Module) when is_list(ChunkId) ->
{AtomTable, {ChunkId, Chunk}}. % Chunk is a binary
-chunk_name_to_id(atoms, _) -> "Atom";
chunk_name_to_id(indexed_imports, _) -> "ImpT";
chunk_name_to_id(imports, _) -> "ImpT";
chunk_name_to_id(exports, _) -> "ExpT";
@@ -692,6 +744,7 @@ chunk_name_to_id(locals, _) -> "LocT";
chunk_name_to_id(labeled_locals, _) -> "LocT";
chunk_name_to_id(attributes, _) -> "Attr";
chunk_name_to_id(abstract_code, _) -> "Abst";
+chunk_name_to_id(debug_info, _) -> "Dbgi";
chunk_name_to_id(compile_info, _) -> "CInf";
chunk_name_to_id(Other, File) ->
error({unknown_chunk, File, Other}).
@@ -738,25 +791,30 @@ atm(AT, N) ->
%% AT is updated.
ensure_atoms({empty, AT}, Cs) ->
- {_Id, AtomChunk} = lists:keyfind("Atom", 1, Cs),
- extract_atoms(AtomChunk, AT),
+ case lists:keyfind("AtU8", 1, Cs) of
+ {_Id, AtomChunk} when is_binary(AtomChunk) ->
+ extract_atoms(AtomChunk, AT, utf8);
+ _ ->
+ {_Id, AtomChunk} = lists:keyfind("Atom", 1, Cs),
+ extract_atoms(AtomChunk, AT, latin1)
+ end,
AT;
ensure_atoms(AT, _Cs) ->
AT.
-extract_atoms(<<_Num:32, B/binary>>, AT) ->
- extract_atoms(B, 1, AT).
+extract_atoms(<<_Num:32, B/binary>>, AT, Encoding) ->
+ extract_atoms(B, 1, AT, Encoding).
-extract_atoms(<<>>, _I, _AT) ->
+extract_atoms(<<>>, _I, _AT, _Encoding) ->
true;
-extract_atoms(B, I, AT) ->
- {Atom, B1} = extract_atom(B),
+extract_atoms(B, I, AT, Encoding) ->
+ {Atom, B1} = extract_atom(B, Encoding),
true = ets:insert(AT, {I, Atom}),
- extract_atoms(B1, I+1, AT).
+ extract_atoms(B1, I+1, AT, Encoding).
-extract_atom(<<Len, B/binary>>) ->
+extract_atom(<<Len, B/binary>>, Encoding) ->
<<SB:Len/binary, Tail/binary>> = B,
- {list_to_atom(binary_to_list(SB)), Tail}.
+ {binary_to_atom(SB, Encoding), Tail}.
%%% Utils.
@@ -856,12 +914,12 @@ significant_chunks() ->
%% for a module. They are listed in the order that they should be MD5:ed.
md5_chunks() ->
- ["Atom", "Code", "StrT", "ImpT", "ExpT", "FunT", "LitT"].
+ ["Atom", "AtU8", "Code", "StrT", "ImpT", "ExpT", "FunT", "LitT"].
%% The following chunks are mandatory in every Beam file.
mandatory_chunks() ->
- ["Code", "ExpT", "ImpT", "StrT", "Atom"].
+ ["Code", "ExpT", "ImpT", "StrT"].
%%% ====================================================================
%%% The rest of the file handles encrypted debug info.
@@ -876,23 +934,18 @@ mandatory_chunks() ->
-define(CRYPTO_KEY_SERVER, beam_lib__crypto_key_server).
-decrypt_abst(Type, Module, File, Id, AtomTable, Bin) ->
+decrypt_chunk(Type, Module, File, Id, Bin) ->
try
KeyString = get_crypto_key({debug_info, Type, Module, File}),
- Key = make_crypto_key(Type, KeyString),
- Term = decrypt_abst_1(Key, Bin),
- {AtomTable, {Id, Term}}
+ {Type,Key,IVec,_BlockSize} = make_crypto_key(Type, KeyString),
+ ok = start_crypto(),
+ NewBin = crypto:block_decrypt(Type, Key, IVec, Bin),
+ binary_to_term(NewBin)
catch
_:_ ->
error({key_missing_or_invalid, File, Id})
end.
-decrypt_abst_1({Type,Key,IVec,_BlockSize}, Bin) ->
- ok = start_crypto(),
- NewBin = crypto:block_decrypt(Type, Key, IVec, Bin),
- Term = binary_to_term(NewBin),
- anno_from_term(Term).
-
anno_from_term({raw_abstract_v1, Forms}) ->
{raw_abstract_v1, anno_from_forms(Forms)};
anno_from_term({Tag, Forms}) when Tag =:= abstract_v1; Tag =:= abstract_v2 ->
diff --git a/lib/stdlib/src/binary.erl b/lib/stdlib/src/binary.erl
index ccc827ca2d..6a64133b45 100644
--- a/lib/stdlib/src/binary.erl
+++ b/lib/stdlib/src/binary.erl
@@ -1,7 +1,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 2010-2016. All Rights Reserved.
+%% Copyright Ericsson AB 2010-2017. All Rights Reserved.
%%
%% Licensed under the Apache License, Version 2.0 (the "License");
%% you may not use this file except in compliance with the License.
@@ -24,7 +24,7 @@
-export_type([cp/0]).
--opaque cp() :: {'am' | 'bm', binary()}.
+-opaque cp() :: {'am' | 'bm', reference()}.
-type part() :: {Start :: non_neg_integer(), Length :: integer()}.
%%% BIFs.
diff --git a/lib/stdlib/src/c.erl b/lib/stdlib/src/c.erl
index ad4915eabe..c04a201ce1 100644
--- a/lib/stdlib/src/c.erl
+++ b/lib/stdlib/src/c.erl
@@ -1,7 +1,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 1996-2016. All Rights Reserved.
+%% Copyright Ericsson AB 1996-2017. All Rights Reserved.
%%
%% Licensed under the Apache License, Version 2.0 (the "License");
%% you may not use this file except in compliance with the License.
@@ -23,10 +23,10 @@
%% Avoid warning for local function error/2 clashing with autoimported BIF.
-compile({no_auto_import,[error/2]}).
--export([help/0,lc/1,c/1,c/2,nc/1,nc/2, nl/1,l/1,i/0,i/1,ni/0,
+-export([help/0,lc/1,c/1,c/2,c/3,nc/1,nc/2, nl/1,l/1,i/0,i/1,ni/0,
y/1, y/2,
lc_batch/0, lc_batch/1,
- i/3,pid/3,m/0,m/1,
+ i/3,pid/3,m/0,m/1,mm/0,lm/0,
bt/1, q/0,
erlangrc/0,erlangrc/1,bi/1, flush/0, regs/0, uptime/0,
nregs/0,pwd/0,ls/0,ls/1,cd/1,memory/1,memory/0, xm/1]).
@@ -35,7 +35,7 @@
-export([appcall/4]).
-import(lists, [reverse/1,flatten/1,sublist/3,sort/1,keysort/2,
- concat/1,max/1,min/1,foreach/2,foldl/3,flatmap/2]).
+ max/1,min/1,foreach/2,foldl/3,flatmap/2]).
-import(io, [format/1, format/2]).
%%-----------------------------------------------------------------------
@@ -44,7 +44,7 @@
help() ->
io:put_chars(<<"bt(Pid) -- stack backtrace for a process\n"
- "c(File) -- compile and load code in <File>\n"
+ "c(Mod) -- compile and load module or file <Mod>\n"
"cd(Dir) -- change working directory\n"
"flush() -- flush any messages sent to the shell\n"
"help() -- help info\n"
@@ -52,11 +52,13 @@ help() ->
"ni() -- information about the networked system\n"
"i(X,Y,Z) -- information about pid <X,Y,Z>\n"
"l(Module) -- load or reload module\n"
+ "lm() -- load all modified modules\n"
"lc([File]) -- compile a list of Erlang modules\n"
"ls() -- list files in the current directory\n"
"ls(Dir) -- list files in directory <Dir>\n"
"m() -- which modules are loaded\n"
"m(Mod) -- information about module <Mod>\n"
+ "mm() -- list all modified modules\n"
"memory() -- memory allocation information\n"
"memory(T) -- memory allocation information of type <T>\n"
"nc(File) -- compile and load code in <File> on all nodes\n"
@@ -70,32 +72,224 @@ help() ->
"xm(M) -- cross reference check a module\n"
"y(File) -- generate a Yecc parser\n">>).
-%% c(FileName)
-%% Compile a file/module.
-
--spec c(File) -> {'ok', Module} | 'error' when
- File :: file:name(),
- Module :: module().
+%% c(Module)
+%% Compile a module/file.
+
+-spec c(Module) -> {'ok', ModuleName} | 'error' when
+ Module :: file:name(),
+ ModuleName :: module().
+
+c(Module) -> c(Module, []).
+
+-spec c(Module, Options) -> {'ok', ModuleName} | 'error' when
+ Module :: file:name(),
+ Options :: [compile:option()] | compile:option(),
+ ModuleName :: module().
+
+c(Module, SingleOption) when not is_list(SingleOption) ->
+ c(Module, [SingleOption]);
+c(Module, Opts) when is_atom(Module) ->
+ %% either a module name or a source file name (possibly without
+ %% suffix); if such a source file exists, it is used to compile from
+ %% scratch with the given options, otherwise look for an object file
+ Suffix = case filename:extension(Module) of
+ "" -> src_suffix(Opts);
+ S -> S
+ end,
+ SrcFile = filename:rootname(Module, Suffix) ++ Suffix,
+ case filelib:is_file(SrcFile) of
+ true ->
+ compile_and_load(SrcFile, Opts);
+ false ->
+ c(Module, Opts, fun (_) -> true end)
+ end;
+c(Module, Opts) ->
+ %% we never interpret a string as a module name, only as a file
+ compile_and_load(Module, Opts).
-c(File) -> c(File, []).
+%% This tries to find an existing object file and use its compile_info and
+%% source path to recompile the module, overwriting the old object file.
+%% The Filter parameter is applied to the old compile options
--spec c(File, Options) -> {'ok', Module} | 'error' when
- File :: file:name(),
+-spec c(Module, Options, Filter) -> {'ok', ModuleName} | 'error' when
+ Module :: atom(),
Options :: [compile:option()],
- Module :: module().
+ Filter :: fun ((compile:option()) -> boolean()),
+ ModuleName :: module().
+
+c(Module, Options, Filter) when is_atom(Module) ->
+ case find_beam(Module) of
+ BeamFile when is_list(BeamFile) ->
+ c(Module, Options, Filter, BeamFile);
+ Error ->
+ {error, Error}
+ end.
+
+c(Module, Options, Filter, BeamFile) ->
+ case compile_info(Module, BeamFile) of
+ Info when is_list(Info) ->
+ case find_source(BeamFile, Info) of
+ SrcFile when is_list(SrcFile) ->
+ c(SrcFile, Options, Filter, BeamFile, Info);
+ Error ->
+ Error
+ end;
+ Error ->
+ Error
+ end.
-c(File, Opts0) when is_list(Opts0) ->
- Opts = [report_errors,report_warnings|Opts0],
+c(SrcFile, NewOpts, Filter, BeamFile, Info) ->
+ %% Filter old options; also remove options that will be replaced.
+ %% Write new beam over old beam unless other outdir is specified.
+ F = fun (Opt) -> not is_outdir_opt(Opt) andalso Filter(Opt) end,
+ Options = (NewOpts ++ [{outdir,filename:dirname(BeamFile)}]
+ ++ lists:filter(F, old_options(Info))),
+ format("Recompiling ~ts\n", [SrcFile]),
+ safe_recompile(SrcFile, Options, BeamFile).
+
+old_options(Info) ->
+ case lists:keyfind(options, 1, Info) of
+ {options, Opts} -> Opts;
+ false -> []
+ end.
+
+%% prefer the source path in the compile info if the file exists,
+%% otherwise do a standard source search relative to the beam file
+find_source(BeamFile, Info) ->
+ case lists:keyfind(source, 1, Info) of
+ {source, SrcFile} ->
+ case filelib:is_file(SrcFile) of
+ true -> SrcFile;
+ false -> find_source(BeamFile)
+ end;
+ _ ->
+ find_source(BeamFile)
+ end.
+
+find_source(BeamFile) ->
+ case filelib:find_source(BeamFile) of
+ {ok, SrcFile} -> SrcFile;
+ _ -> {error, no_source}
+ end.
+
+%% find the beam file for a module, preferring the path reported by code:which()
+%% if it still exists, or otherwise by searching the code path
+find_beam(Module) when is_atom(Module) ->
+ case code:which(Module) of
+ Beam when is_list(Beam), Beam =/= "" ->
+ case erlang:module_loaded(Module) of
+ false ->
+ Beam; % code:which/1 found this in the path
+ true ->
+ case filelib:is_file(Beam) of
+ true -> Beam;
+ false -> find_beam_1(Module) % file moved?
+ end
+ end;
+ Other when Other =:= ""; Other =:= cover_compiled ->
+ %% module is loaded but not compiled directly from source
+ find_beam_1(Module);
+ Error ->
+ Error
+ end.
+
+find_beam_1(Module) ->
+ File = atom_to_list(Module) ++ code:objfile_extension(),
+ case code:where_is_file(File) of
+ Beam when is_list(Beam) ->
+ Beam;
+ Error ->
+ Error
+ end.
+
+%% get the compile_info for a module
+%% -will report the info for the module in memory, if loaded
+%% -will try to find and examine the beam file if not in memory
+%% -will not cause a module to become loaded by accident
+compile_info(Module, Beam) when is_atom(Module) ->
+ case erlang:module_loaded(Module) of
+ true ->
+ %% getting the compile info for a loaded module should normally
+ %% work, but return an empty info list if it fails
+ try erlang:get_module_info(Module, compile)
+ catch _:_ -> []
+ end;
+ false ->
+ case beam_lib:chunks(Beam, [compile_info]) of
+ {ok, {_Module, [{compile_info, Info}]}} ->
+ Info;
+ Error ->
+ Error
+ end
+ end.
+
+%% compile module, backing up any existing target file and restoring the
+%% old version if compilation fails (this should only be used when we have
+%% an old beam file that we want to preserve)
+safe_recompile(File, Options, BeamFile) ->
+ %% Note that it's possible that because of options such as 'to_asm',
+ %% the compiler might not actually write a new beam file at all
+ Backup = BeamFile ++ ".bak",
+ case file:rename(BeamFile, Backup) of
+ Status when Status =:= ok; Status =:= {error,enoent} ->
+ case compile_and_load(File, Options) of
+ {ok, _} = Result ->
+ _ = if Status =:= ok -> file:delete(Backup);
+ true -> ok
+ end,
+ Result;
+ Error ->
+ _ = if Status =:= ok -> file:rename(Backup, BeamFile);
+ true -> ok
+ end,
+ Error
+ end;
+ Error ->
+ Error
+ end.
+
+%% Compile the file and load the resulting object code (if any).
+%% Automatically ensures that there is an outdir option, by default the
+%% directory of File, and that a 'from' option will be passed to match the
+%% actual source suffix if needed (unless already specified).
+compile_and_load(File, Opts0) when is_list(Opts0) ->
+ Opts = [report_errors, report_warnings
+ | ensure_from(filename:extension(File),
+ ensure_outdir(".", Opts0))],
case compile:file(File, Opts) of
{ok,Mod} -> %Listing file.
- machine_load(Mod, File, Opts);
+ purge_and_load(Mod, File, Opts);
{ok,Mod,_Ws} -> %Warnings maybe turned on.
- machine_load(Mod, File, Opts);
+ purge_and_load(Mod, File, Opts);
Other -> %Errors go here
Other
end;
-c(File, Opt) ->
- c(File, [Opt]).
+compile_and_load(File, Opt) ->
+ compile_and_load(File, [Opt]).
+
+ensure_from(Suffix, Opts0) ->
+ case lists:partition(fun is_from_opt/1, Opts0++from_opt(Suffix)) of
+ {[Opt|_], Opts} -> [Opt | Opts];
+ {[], Opts} -> Opts
+ end.
+
+ensure_outdir(Dir, Opts0) ->
+ {[Opt|_], Opts} = lists:partition(fun is_outdir_opt/1,
+ Opts0++[{outdir,Dir}]),
+ [Opt | Opts].
+
+is_outdir_opt({outdir, _}) -> true;
+is_outdir_opt(_) -> false.
+
+is_from_opt(from_core) -> true;
+is_from_opt(from_asm) -> true;
+is_from_opt(from_beam) -> true;
+is_from_opt(_) -> false.
+
+from_opt(".core") -> [from_core];
+from_opt(".S") -> [from_asm];
+from_opt(".beam") -> [from_beam];
+from_opt(_) -> [].
%%% Obtain the 'outdir' option from the argument. Return "." if no
%%% such option was given.
@@ -111,18 +305,29 @@ outdir([Opt|Rest]) ->
outdir(Rest)
end.
+%% mimic how suffix is selected in compile:file().
+src_suffix([from_core|_]) -> ".core";
+src_suffix([from_asm|_]) -> ".S";
+src_suffix([from_beam|_]) -> ".beam";
+src_suffix([_|Opts]) -> src_suffix(Opts);
+src_suffix([]) -> ".erl".
+
%%% We have compiled File with options Opts. Find out where the
-%%% output file went to, and load it.
-machine_load(Mod, File, Opts) ->
+%%% output file went and load it, purging any old version.
+purge_and_load(Mod, File, Opts) ->
Dir = outdir(Opts),
- File2 = filename:join(Dir, filename:basename(File, ".erl")),
+ Base = filename:basename(File, src_suffix(Opts)),
+ OutFile = filename:join(Dir, Base),
case compile:output_generated(Opts) of
true ->
- Base = atom_to_list(Mod),
- case filename:basename(File, ".erl") of
+ case atom_to_list(Mod) of
Base ->
code:purge(Mod),
- check_load(code:load_abs(File2,Mod), Mod);
+ %% Note that load_abs() adds the object file suffix
+ case code:load_abs(OutFile, Mod) of
+ {error, _R}=Error -> Error;
+ _ -> {ok, Mod}
+ end;
_OtherMod ->
format("** Module name '~p' does not match file name '~tp' **~n",
[Mod,File]),
@@ -133,13 +338,6 @@ machine_load(Mod, File, Opts) ->
ok
end.
-%%% This function previously warned if the loaded module was
-%%% loaded from some other place than current directory.
-%%% Now, loading from other than current directory is supposed to work.
-%%% so this function does nothing special.
-check_load({error, _R} = Error, _) -> Error;
-check_load(_, Mod) -> {ok, Mod}.
-
%% Compile a list of modules
%% enables the nice unix shell cmd
%% erl -s c lc f1 f2 f3 @d c1=v1 @c2 @i IDir @o ODir -s erlang halt
@@ -202,7 +400,7 @@ split_def([], Res) -> {d, list_to_atom(reverse(Res))}.
make_term(Str) ->
case erl_scan:string(Str) of
{ok, Tokens, _} ->
- case erl_parse:parse_term(Tokens ++ [{dot, 1}]) of
+ case erl_parse:parse_term(Tokens ++ [{dot, erl_anno:new(1)}]) of
{ok, Term} -> Term;
{error, {_,_,Reason}} ->
io:format("~ts: ~ts~n", [Reason, Str]),
@@ -350,7 +548,7 @@ mfa_string(Fun) when is_function(Fun) ->
{arity,A} = erlang:fun_info(Fun, arity),
mfa_string({M,F,A});
mfa_string({M,F,A}) ->
- io_lib:format("~w:~w/~w", [M,F,A]);
+ io_lib:format("~w:~tw/~w", [M,F,A]);
mfa_string(X) ->
w(X).
@@ -374,7 +572,7 @@ display_info(Pid) ->
w(Reds), w(LM)),
iformat(case fetch(registered_name, Info) of
0 -> "";
- X -> w(X)
+ X -> io_lib:format("~tw", [X])
end,
mfa_string(Curr),
w(SS),
@@ -396,7 +594,7 @@ initial_call(Info) ->
end.
iformat(A1, A2, A3, A4, A5) ->
- format("~-21s ~-33s ~8s ~8s ~4s~n", [A1,A2,A3,A4,A5]).
+ format("~-21ts ~-33ts ~8s ~8s ~4s~n", [A1,A2,A3,A4,A5]).
all_procs() ->
case is_alive() of
@@ -459,6 +657,16 @@ m() ->
mformat(A1, A2) ->
format("~-20s ~ts\n", [A1,A2]).
+-spec mm() -> [module()].
+
+mm() ->
+ code:modified_modules().
+
+-spec lm() -> [code:load_ret()].
+
+lm() ->
+ [l(M) || M <- mm()].
+
%% erlangrc(Home)
%% Try to run a ".erlang" file, first in the current directory
%% else in home directory.
@@ -559,7 +767,7 @@ print_exports(X) when length(X) > 16 ->
split_print_exports(X);
print_exports([]) -> ok;
print_exports([{F, A} |Tail]) ->
- format(" ~w/~w~n",[F, A]),
+ format(" ~tw/~w~n",[F, A]),
print_exports(Tail).
split_print_exports(L) ->
@@ -571,11 +779,11 @@ split_print_exports(L) ->
split_print_exports([], [{F, A}|T]) ->
Str = " ",
- format("~-30s~w/~w~n", [Str, F, A]),
+ format("~-30ts~tw/~w~n", [Str, F, A]),
split_print_exports([], T);
split_print_exports([{F1, A1}|T1], [{F2, A2} | T2]) ->
- Str = flatten(io_lib:format("~w/~w", [F1, A1])),
- format("~-30s~w/~w~n", [Str, F2, A2]),
+ Str = flatten(io_lib:format("~tw/~w", [F1, A1])),
+ format("~-30ts~tw/~w~n", [Str, F2, A2]),
split_print_exports(T1, T2);
split_print_exports([], []) -> ok.
@@ -675,22 +883,22 @@ procline(Name, Info, Pid) ->
Call = initial_call(Info),
Reds = fetch(reductions, Info),
LM = length(fetch(messages, Info)),
- procformat(io_lib:format("~w",[Name]),
+ procformat(io_lib:format("~tw",[Name]),
io_lib:format("~w",[Pid]),
- io_lib:format("~s",[mfa_string(Call)]),
+ io_lib:format("~ts",[mfa_string(Call)]),
integer_to_list(Reds), integer_to_list(LM)).
procformat(Name, Pid, Call, Reds, LM) ->
- format("~-21s ~-12s ~-25s ~12s ~4s~n", [Name,Pid,Call,Reds,LM]).
+ format("~-21ts ~-12s ~-25ts ~12s ~4s~n", [Name,Pid,Call,Reds,LM]).
portline(Name, Info, Id) ->
Cmd = fetch(name, Info),
- portformat(io_lib:format("~w",[Name]),
+ portformat(io_lib:format("~tw",[Name]),
erlang:port_to_list(Id),
Cmd).
portformat(Name, Id, Cmd) ->
- format("~-21s ~-15s ~-40s~n", [Name,Id,Cmd]).
+ format("~-21ts ~-15s ~-40ts~n", [Name,Id,Cmd]).
%% pwd()
%% cd(Directory)
diff --git a/lib/stdlib/src/dets.erl b/lib/stdlib/src/dets.erl
index bf22949870..10e8c9c800 100644
--- a/lib/stdlib/src/dets.erl
+++ b/lib/stdlib/src/dets.erl
@@ -1,7 +1,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 1996-2016. All Rights Reserved.
+%% Copyright Ericsson AB 1996-2017. All Rights Reserved.
%%
%% Licensed under the Apache License, Version 2.0 (the "License");
%% you may not use this file except in compliance with the License.
@@ -105,9 +105,6 @@
%%% the file with the split indicator, size etc is held in ram by the
%%% server at all times.
%%%
-%%% The parts specific for formats up to and including 8(c) are
-%%% implemented in dets_v8.erl, parts specific for format 9 are
-%%% implemented in dets_v9.erl.
%% The method of hashing is the so called linear hashing algorithm
%% with segments.
@@ -140,28 +137,33 @@
%%% written, and a repair is forced next time the file is opened.
-record(dets_cont, {
- what, % object | bindings | select | bchunk
- no_objs, % requested number of objects: default | integer() > 0
- bin, % small chunk not consumed, or 'eof' at end-of-file
- alloc, % the part of the file not yet scanned, mostly a binary
- tab,
- proc, % the pid of the Dets process
- match_program % true | compiled_match_spec() | undefined
+ what :: 'undefined' | 'bchunk' | 'bindings' | 'object' | 'select',
+ no_objs :: 'default' | pos_integer(), % requested number of objects
+ bin :: 'eof' | binary(), % small chunk not consumed,
+ % or 'eof' at end-of-file
+ alloc :: binary() % the part of the file not yet scanned
+ | {From :: non_neg_integer(),
+ To :: non_neg_integer,
+ binary()},
+ tab :: tab_name(),
+ proc :: 'undefined' | pid(), % the pid of the Dets process
+ match_program :: 'true'
+ | 'undefined'
+ | {'match_spec', ets:comp_match_spec()}
}).
-record(open_args, {
- file,
- type,
- keypos,
- repair,
- min_no_slots,
- max_no_slots,
- ram_file,
- delayed_write,
- auto_save,
- access,
- version,
- debug
+ file :: list(),
+ type :: type(),
+ keypos :: keypos(),
+ repair :: 'force' | boolean(),
+ min_no_slots :: no_slots(),
+ max_no_slots :: no_slots(),
+ ram_file :: boolean(),
+ delayed_write :: cache_parms(),
+ auto_save :: auto_save(),
+ access :: access(),
+ debug :: boolean()
}).
-define(PATTERN_TO_OBJECT_MATCH_SPEC(Pat), [{Pat,[],['$_']}]).
@@ -177,20 +179,13 @@
%%-define(PROFILE(C), C).
-define(PROFILE(C), void).
--type access() :: 'read' | 'read_write'.
--type auto_save() :: 'infinity' | non_neg_integer().
-opaque bindings_cont() :: #dets_cont{}.
-opaque cont() :: #dets_cont{}.
--type keypos() :: pos_integer().
-type match_spec() :: ets:match_spec().
-type object() :: tuple().
--type no_slots() :: non_neg_integer() | 'default'.
-opaque object_cont() :: #dets_cont{}.
-type pattern() :: atom() | tuple().
-opaque select_cont() :: #dets_cont{}.
--type tab_name() :: term().
--type type() :: 'bag' | 'duplicate_bag' | 'set'.
--type version() :: 8 | 9 | 'default'.
%%% Some further debug code was added in R12B-1 (stdlib-1.15.1):
%%% - there is a new open_file() option 'debug';
@@ -273,19 +268,20 @@ delete_all_objects(Tab) ->
delete_object(Tab, O) ->
badarg(treq(Tab, {delete_object, [O]}), [Tab, O]).
+%% Backwards compatibility.
+fsck(Fname, _Version) ->
+ fsck(Fname).
+
%% Given a filename, fsck it. Debug.
fsck(Fname) ->
- fsck(Fname, default).
-
-fsck(Fname, Version) ->
catch begin
{ok, Fd, FH} = read_file_header(Fname, read, false),
?DEBUGF("FileHeader: ~p~n", [FH]),
- case (FH#fileheader.mod):check_file_header(FH, Fd) of
+ case dets_v9:check_file_header(FH, Fd) of
{error, not_closed} ->
- fsck(Fd, make_ref(), Fname, FH, default, default, Version);
- {ok, _Head, _Extra} ->
- fsck(Fd, make_ref(), Fname, FH, default, default, Version);
+ fsck(Fd, make_ref(), Fname, FH, default, default);
+ {ok, _Head} ->
+ fsck(Fd, make_ref(), Fname, FH, default, default);
Error ->
Error
end
@@ -372,7 +368,7 @@ info(Tab) ->
Item :: 'access' | 'auto_save' | 'bchunk_format'
| 'hash' | 'file_size' | 'filename' | 'keypos' | 'memory'
| 'no_keys' | 'no_objects' | 'no_slots' | 'owner' | 'ram_file'
- | 'safe_fixed' | 'safe_fixed_monotonic_time' | 'size' | 'type' | 'version',
+ | 'safe_fixed' | 'safe_fixed_monotonic_time' | 'size' | 'type',
Value :: term().
info(Tab, owner) ->
@@ -640,8 +636,7 @@ open_file(File) ->
| {'keypos', keypos()}
| {'ram_file', boolean()}
| {'repair', boolean() | 'force'}
- | {'type', type()}
- | {'version', version()},
+ | {'type', type()},
Reason :: term().
open_file(Tab, Args) when is_list(Args) ->
@@ -674,13 +669,13 @@ remove_user(Pid, From) ->
Continuation2 :: select_cont(),
MatchSpec :: match_spec().
-repair_continuation(#dets_cont{match_program = B}=Cont, MS)
- when is_binary(B) ->
+repair_continuation(#dets_cont{match_program = {match_spec, B}}=Cont, MS) ->
case ets:is_compiled_ms(B) of
true ->
Cont;
false ->
- Cont#dets_cont{match_program = ets:match_spec_compile(MS)}
+ Cont#dets_cont{match_program = {match_spec,
+ ets:match_spec_compile(MS)}}
end;
repair_continuation(#dets_cont{}=Cont, _MS) ->
Cont;
@@ -999,7 +994,9 @@ init_chunk_match(Tab, Pat, What, N, Safe) when is_integer(N), N >= 0;
case req(Proc, {match, MP, Spec, N, Safe}) of
{done, L} ->
{L, #dets_cont{tab = Tab, proc = Proc,
- what = What, bin = eof}};
+ what = What, bin = eof,
+ no_objs = default,
+ alloc = <<>>}};
{cont, State} ->
chunk_match(State#dets_cont{what = What,
tab = Tab,
@@ -1041,17 +1038,17 @@ chunk_match(#dets_cont{proc = Proc}=State, Safe) ->
do_foldl_bins(Bins, true) ->
foldl_bins(Bins, []);
-do_foldl_bins(Bins, MP) ->
+do_foldl_bins(Bins, {match_spec, MP}) ->
foldl_bins(Bins, MP, []).
foldl_bins([], Terms) ->
- %% Preserve time order (version 9).
+ %% Preserve time order.
Terms;
foldl_bins([Bin | Bins], Terms) ->
foldl_bins(Bins, [binary_to_term(Bin) | Terms]).
foldl_bins([], _MP, Terms) ->
- %% Preserve time order (version 9).
+ %% Preserve time order.
Terms;
foldl_bins([Bin | Bins], MP, Terms) ->
Term = binary_to_term(Bin),
@@ -1066,11 +1063,8 @@ foldl_bins([Bin | Bins], MP, Terms) ->
compile_match_spec(select, ?PATTERN_TO_OBJECT_MATCH_SPEC('_') = Spec) ->
{Spec, true};
compile_match_spec(select, Spec) ->
- case catch ets:match_spec_compile(Spec) of
- X when is_binary(X) ->
- {Spec, X};
- _ ->
- badarg
+ try {Spec, {match_spec, ets:match_spec_compile(Spec)}}
+ catch error:_ -> badarg
end;
compile_match_spec(object, Pat) ->
compile_match_spec(select, ?PATTERN_TO_OBJECT_MATCH_SPEC(Pat));
@@ -1091,16 +1085,10 @@ defaults(Tab, Args) ->
delayed_write = ?DEFAULT_CACHE,
auto_save = timer:minutes(?DEFAULT_AUTOSAVE),
access = read_write,
- version = default,
debug = false},
Fun = fun repl/2,
Defaults = lists:foldl(Fun, Defaults0, Args),
- case Defaults#open_args.version of
- 8 ->
- Defaults#open_args{max_no_slots = default};
- _ ->
- is_comp_min_max(Defaults)
- end.
+ is_comp_min_max(Defaults).
to_list(T) when is_atom(T) -> atom_to_list(T);
to_list(T) -> T.
@@ -1131,7 +1119,6 @@ repl({file, File}, Defs) when is_atom(File) ->
repl({keypos, P}, Defs) when is_integer(P), P > 0 ->
Defs#open_args{keypos =P};
repl({max_no_slots, I}, Defs) ->
- %% Version 9 only.
MaxSlots = is_max_no_slots(I),
Defs#open_args{max_no_slots = MaxSlots};
repl({min_no_slots, I}, Defs) ->
@@ -1147,8 +1134,9 @@ repl({type, T}, Defs) ->
mem(T, [set, bag, duplicate_bag]),
Defs#open_args{type =T};
repl({version, Version}, Defs) ->
- V = is_version(Version),
- Defs#open_args{version = V};
+ %% Backwards compatibility.
+ is_version(Version),
+ Defs;
repl({debug, Bool}, Defs) ->
%% Not documented.
mem(Bool, [true, false]),
@@ -1164,16 +1152,15 @@ is_max_no_slots(default) -> default;
is_max_no_slots(I) when is_integer(I), I > 0, I < 1 bsl 31 -> I.
is_comp_min_max(Defs) ->
- #open_args{max_no_slots = Max, min_no_slots = Min, version = V} = Defs,
- case V of
- _ when Min =:= default -> Defs;
- _ when Max =:= default -> Defs;
- _ -> true = Min =< Max, Defs
+ #open_args{max_no_slots = Max, min_no_slots = Min} = Defs,
+ if
+ Min =:= default -> Defs;
+ Max =:= default -> Defs;
+ true -> true = Min =< Max, Defs
end.
-is_version(default) -> default;
-is_version(8) -> 8;
-is_version(9) -> 9.
+is_version(default) -> true;
+is_version(9) -> true.
mem(X, L) ->
case lists:member(X, L) of
@@ -1288,17 +1275,23 @@ badarg_exit(Reply, _A) ->
init(Parent, Server) ->
process_flag(trap_exit, true),
- open_file_loop(#head{parent = Parent, server = Server}).
-
-open_file_loop(Head) ->
%% 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) ->
- do_apply_op(Op, From, Head, 0)
+ ?DETS_CALL(From, {internal_open, Ref, Args}=Op) ->
+ try do_internal_open(Parent, Server, From, Ref, Args) of
+ Head ->
+ open_file_loop(Head, 0)
+ catch
+ exit:normal ->
+ exit(normal);
+ _:Bad ->
+ bug_found(no_name, Op, Bad, From),
+ exit(Bad) % give up
+ end
end.
open_file_loop(Head, N) when element(1, Head#head.update_mode) =:= error ->
@@ -1379,28 +1372,7 @@ do_apply_op(Op, From, Head, N) ->
exit:normal ->
exit(normal);
_:Bad ->
- Name = Head#head.name,
- case dets_utils:debug_mode() of
- true ->
- %% If stream_op/5 found more requests, this is not
- %% the last operation.
- error_logger:format
- ("** dets: Bug was found when accessing table ~w,~n"
- "** dets: operation was ~p and reply was ~w.~n"
- "** dets: Stacktrace: ~w~n",
- [Name, Op, Bad, erlang:get_stacktrace()]);
- false ->
- error_logger:format
- ("** dets: Bug was found when accessing table ~w~n",
- [Name])
- end,
- if
- From =/= self() ->
- From ! {self(), {error, {dets_bug, Name, Op, Bad}}},
- ok;
- true -> % auto_save | may_grow | {delayed_write, _}
- ok
- end,
+ bug_found(Head#head.name, Op, Bad, From),
open_file_loop(Head, N)
end.
@@ -1408,10 +1380,7 @@ apply_op(Op, From, Head, N) ->
case Op of
{add_user, Tab, OpenArgs}->
#open_args{file = Fname, type = Type, keypos = Keypos,
- ram_file = Ram, access = Access,
- version = Version} = OpenArgs,
- VersionOK = (Version =:= default) or
- (Head#head.version =:= Version),
+ ram_file = Ram, access = Access} = OpenArgs,
%% min_no_slots and max_no_slots are not tested
Res = if
Tab =:= Head#head.name,
@@ -1419,7 +1388,6 @@ apply_op(Op, From, Head, N) ->
Head#head.type =:= Type,
Head#head.ram_file =:= Ram,
Head#head.access =:= Access,
- VersionOK,
Fname =:= Head#head.filename ->
ok;
true ->
@@ -1475,21 +1443,14 @@ apply_op(Op, From, Head, N) ->
From ! {self(), Res},
ok;
{internal_open, Ref, Args} ->
- ?PROFILE(ep:do()),
- case do_open_file(Args, Head#head.parent, Head#head.server,Ref) of
- {ok, H2} ->
- From ! {self(), ok},
- H2;
- Error ->
- From ! {self(), Error},
- exit(normal)
- end;
+ do_internal_open(Head#head.parent, Head#head.server, From,
+ Ref, Args);
may_grow when Head#head.update_mode =/= saved ->
if
Head#head.update_mode =:= dirty ->
%% Won't grow more if the table is full.
{H2, _Res} =
- (Head#head.mod):may_grow(Head, 0, many_times),
+ dets_v9:may_grow(Head, 0, many_times),
{N + 1, H2};
true ->
ok
@@ -1519,21 +1480,10 @@ apply_op(Op, From, Head, N) ->
From ! {self(), Res},
erlang:garbage_collect(),
{0, H2};
- {delete_key, Keys} when Head#head.update_mode =:= dirty ->
- if
- Head#head.version =:= 8 ->
- {H2, Res} = fdelete_key(Head, Keys),
- From ! {self(), Res},
- {N + 1, H2};
- true ->
- stream_op(Op, From, [], Head, N)
- end;
+ {delete_key, _Keys} when Head#head.update_mode =:= dirty ->
+ stream_op(Op, From, [], Head, N);
{delete_object, Objs} when Head#head.update_mode =:= dirty ->
case check_objects(Objs, Head#head.keypos) of
- true when Head#head.version =:= 8 ->
- {H2, Res} = fdelete_object(Head, Objs),
- From ! {self(), Res},
- {N + 1, H2};
true ->
stream_op(Op, From, [], Head, N);
false ->
@@ -1551,10 +1501,6 @@ apply_op(Op, From, Head, N) ->
H2;
{insert, Objs} when Head#head.update_mode =:= dirty ->
case check_objects(Objs, Head#head.keypos) of
- true when Head#head.version =:= 8 ->
- {H2, Res} = finsert(Head, Objs),
- From ! {self(), Res},
- {N + 1, H2};
true ->
stream_op(Op, From, [], Head, N);
false ->
@@ -1565,10 +1511,6 @@ apply_op(Op, From, Head, N) ->
{H2, Res} = finsert_new(Head, Objs),
From ! {self(), Res},
{N + 1, H2};
- {lookup_keys, Keys} when Head#head.version =:= 8 ->
- {H2, Res} = flookup_keys(Head, Keys),
- From ! {self(), Res},
- H2;
{lookup_keys, _Keys} ->
stream_op(Op, From, [], Head, N);
{match_init, State, Safe} ->
@@ -1584,10 +1526,6 @@ apply_op(Op, From, Head, N) ->
{H2, Res} = fmatch(Head, MP, Spec, NObjs, Safe, From),
From ! {self(), Res},
H2;
- {member, Key} when Head#head.version =:= 8 ->
- {H2, Res} = fmember(Head, Key),
- From ! {self(), Res},
- H2;
{member, _Key} = Op ->
stream_op(Op, From, [], Head, N);
{next, Key} ->
@@ -1628,7 +1566,7 @@ apply_op(Op, From, Head, N) ->
apply_op(WriteOp, From, H2, 0);
WriteOp when Head#head.access =:= read_write,
Head#head.update_mode =:= saved ->
- case catch (Head#head.mod):mark_dirty(Head) of
+ case catch dets_v9:mark_dirty(Head) of
ok ->
start_auto_save_timer(Head),
H2 = Head#head{update_mode = dirty},
@@ -1643,6 +1581,40 @@ apply_op(Op, From, Head, N) ->
ok
end.
+bug_found(Name, Op, Bad, From) ->
+ case dets_utils:debug_mode() of
+ true ->
+ %% If stream_op/5 found more requests, this is not
+ %% the last operation.
+ error_logger:format
+ ("** dets: Bug was found when accessing table ~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.
+
+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) ->
@@ -1650,7 +1622,7 @@ start_auto_save_timer(Head) ->
_Ref = erlang:send_after(Millis, self(), ?DETS_CALL(self(), auto_save)),
ok.
-%% Version 9: Peek the message queue and try to evaluate several
+%% Peek the message queue and try to evaluate several
%% lookup requests in parallel. Evalute delete_object, delete and
%% insert as well.
stream_op(Op, Pid, Pids, Head, N) ->
@@ -1760,7 +1732,7 @@ lookup_reply(P, O) ->
%% Callback functions for system messages handling.
%%-----------------------------------------------------------------
system_continue(_Parent, _, Head) ->
- open_file_loop(Head).
+ open_file_loop(Head, 0).
system_terminate(Reason, _Parent, _, Head) ->
_NewHead = do_stop(Head),
@@ -1793,7 +1765,8 @@ read_file_header(FileName, Access, RamFile) ->
dets_utils:pread_close(Fd, FileName, ?FILE_FORMAT_VERSION_POS, 4),
if
Version =< 8 ->
- dets_v8:read_file_header(Fd, FileName);
+ _ = file:close(Fd),
+ throw({error, {format_8_no_longer_supported, FileName}});
Version =:= 9 ->
dets_v9:read_file_header(Fd, FileName);
true ->
@@ -1820,7 +1793,7 @@ perform_save(Head, DoSync) when Head#head.update_mode =:= dirty;
Head#head.update_mode =:= new_dirty ->
case catch begin
{Head1, []} = write_cache(Head),
- {Head2, ok} = (Head1#head.mod):do_perform_save(Head1),
+ {Head2, ok} = dets_v9:do_perform_save(Head1),
ok = ensure_written(Head2, DoSync),
{Head2#head{update_mode = saved}, ok}
end of
@@ -1853,7 +1826,7 @@ ensure_written(Head, false) when not Head#head.ram_file ->
do_bchunk_init(Head, Tab) ->
case catch write_cache(Head) of
{H2, []} ->
- case (H2#head.mod):table_parameters(H2) of
+ case dets_v9:table_parameters(H2) of
undefined ->
{H2, {error, old_version}};
Parms ->
@@ -1862,9 +1835,9 @@ do_bchunk_init(Head, Tab) ->
L =:= <<>> -> eof;
true -> <<>>
end,
- C0 = #dets_cont{no_objs = default, bin = Bin, alloc = L},
BinParms = term_to_binary(Parms),
- {H2, {C0#dets_cont{tab = Tab, proc = self(),what = bchunk},
+ {H2, {#dets_cont{no_objs = default, bin = Bin, alloc = L,
+ tab = Tab, proc = self(),what = bchunk},
[BinParms]}}
end;
{NewHead, _} = HeadError when is_record(NewHead, head) ->
@@ -1904,16 +1877,8 @@ do_delete_all_objects(Head) ->
max_no_slots = MaxSlots, cache = Cache} = Head,
CacheSz = dets_utils:cache_size(Cache),
ok = dets_utils:truncate(Fd, Fname, bof),
- (Head#head.mod):initiate_file(Fd, Tab, Fname, Type, Kp, MinSlots, MaxSlots,
- Ram, CacheSz, Auto, true).
-
-%% -> {NewHead, Reply}, Reply = ok | Error.
-fdelete_key(Head, Keys) ->
- do_delete(Head, Keys, delete_key).
-
-%% -> {NewHead, Reply}, Reply = ok | badarg | Error.
-fdelete_object(Head, Objects) ->
- do_delete(Head, Objects, delete_object).
+ dets_v9:initiate_file(Fd, Tab, Fname, Type, Kp, MinSlots, MaxSlots,
+ Ram, CacheSz, Auto, true).
ffirst(H) ->
Ref = make_ref(),
@@ -1930,7 +1895,7 @@ ffirst1(H) ->
ffirst(NH, 0).
ffirst(H, Slot) ->
- case (H#head.mod):slot_objs(H, Slot) of
+ case dets_v9:slot_objs(H, Slot) of
'$end_of_table' -> {H, '$end_of_table'};
[] -> ffirst(H, Slot+1);
[X|_] -> {H, element(H#head.keypos, X)}
@@ -2067,7 +2032,7 @@ finfo(H, auto_save) -> {H, H#head.auto_save};
finfo(H, bchunk_format) ->
case catch write_cache(H) of
{H2, []} ->
- case (H2#head.mod):table_parameters(H2) of
+ case dets_v9:table_parameters(H2) of
undefined = Undef ->
{H2, Undef};
Parms ->
@@ -2100,7 +2065,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) ->
@@ -2127,7 +2092,7 @@ finfo(H, size) ->
HeadError
end;
finfo(H, type) -> {H, H#head.type};
-finfo(H, version) -> {H, H#head.version};
+finfo(H, version) -> {H, 9};
finfo(H, _) -> {H, undefined}.
file_size(Fd, FileName) ->
@@ -2136,8 +2101,6 @@ file_size(Fd, FileName) ->
test_bchunk_format(_Head, undefined) ->
false;
-test_bchunk_format(Head, _Term) when Head#head.version =:= 8 ->
- false;
test_bchunk_format(Head, Term) ->
dets_v9:try_bchunk_header(Term, Head) =/= not_ok.
@@ -2206,7 +2169,7 @@ do_finit(Head, Init, Format, NoSlots) ->
#head{fptr = Fd, type = Type, keypos = Kp, auto_save = Auto,
cache = Cache, filename = Fname, ram_file = Ram,
min_no_slots = MinSlots0, max_no_slots = MaxSlots,
- name = Tab, update_mode = UpdateMode, mod = HMod} = Head,
+ name = Tab, update_mode = UpdateMode} = Head,
CacheSz = dets_utils:cache_size(Cache),
{How, Head1} =
case Format of
@@ -2219,9 +2182,10 @@ do_finit(Head, Init, Format, NoSlots) ->
{general_init, Head};
true ->
ok = dets_utils:truncate(Fd, Fname, bof),
- {ok, H} = HMod:initiate_file(Fd, Tab, Fname, Type, Kp,
- MinSlots, MaxSlots, Ram,
- CacheSz, Auto, false),
+ {ok, H} =
+ dets_v9:initiate_file(Fd, Tab, Fname, Type, Kp,
+ MinSlots, MaxSlots, Ram,
+ CacheSz, Auto, false),
{general_init, H}
end;
bchunk ->
@@ -2230,7 +2194,7 @@ do_finit(Head, Init, Format, NoSlots) ->
end,
case How of
bchunk_init ->
- case HMod:bchunk_init(Head1, Init) of
+ case dets_v9:bchunk_init(Head1, Init) of
{ok, NewHead} ->
{ok, NewHead#head{update_mode = dirty}};
Error ->
@@ -2238,10 +2202,10 @@ do_finit(Head, Init, Format, NoSlots) ->
end;
general_init ->
Cntrs = ets:new(dets_init, []),
- Input = HMod:bulk_input(Head1, Init, Cntrs),
+ Input = dets_v9:bulk_input(Head1, Init, Cntrs),
SlotNumbers = {Head1#head.min_no_slots, bulk_init, MaxSlots},
{Reply, SizeData} =
- do_sort(Head1, SlotNumbers, Input, Cntrs, Fname, not_used),
+ do_sort(Head1, SlotNumbers, Input, Cntrs, Fname),
Bulk = true,
case Reply of
{ok, NoDups, H1} ->
@@ -2297,7 +2261,8 @@ fmatch(Head, MP, Spec, N, Safe, From) ->
{NewHead, Reply} = flookup_keys(Head, Keys),
case Reply of
Objs when is_list(Objs) ->
- MatchingObjs = ets:match_spec_run(Objs, MP),
+ {match_spec, MS} = MP,
+ MatchingObjs = ets:match_spec_run(Objs, MS),
{NewHead, {done, MatchingObjs}};
Error ->
{NewHead, Error}
@@ -2377,7 +2342,7 @@ fmatch_delete(Head, C) ->
{[], _} ->
{Head, {done, 0}};
{RTs, NC} ->
- MP = C#dets_cont.match_program,
+ {match_spec, MP} = C#dets_cont.match_program,
case catch filter_binary_terms(RTs, MP, []) of
{'EXIT', _} ->
Bad = dets_utils:bad_object(fmatch_delete, RTs),
@@ -2405,7 +2370,7 @@ do_fmatch_delete_var_keys(Head, MP, _Spec, From) ->
C0 = init_scan(NewHead, default),
{NewHead, {cont, C0#dets_cont{match_program = MP}, 0}}.
-do_fmatch_constant_keys(Head, Keys, MP) ->
+do_fmatch_constant_keys(Head, Keys, {match_spec, MP}) ->
case flookup_keys(Head, Keys) of
{NewHead, ReadTerms} when is_list(ReadTerms) ->
Terms = filter_terms(ReadTerms, MP, []),
@@ -2454,18 +2419,8 @@ do_delete(Head, Things, What) ->
HeadError
end.
-fmember(Head, Key) ->
- case catch begin
- {Head2, [{_NoPid,Objs}]} =
- update_cache(Head, [Key], {lookup, nopid}),
- {Head2, Objs =/= []}
- end of
- {NewHead, _} = Reply when is_record(NewHead, head) ->
- Reply
- end.
-
fnext(Head, Key) ->
- Slot = (Head#head.mod):db_hash(Key, Head),
+ Slot = dets_v9:db_hash(Key, Head),
Ref = make_ref(),
case catch {Ref, fnext(Head, Key, Slot)} of
{Ref, {H, R}} ->
@@ -2476,7 +2431,7 @@ fnext(Head, Key) ->
fnext(H, Key, Slot) ->
{NH, []} = write_cache(H),
- case (H#head.mod):slot_objs(NH, Slot) of
+ case dets_v9:slot_objs(NH, Slot) of
'$end_of_table' -> {NH, '$end_of_table'};
L -> fnext_search(NH, Key, Slot, L)
end.
@@ -2490,7 +2445,7 @@ fnext_search(H, K, Slot, L) ->
%% We've got to continue to search for the next key in the next slot
fnext_slot(H, K, Slot) ->
- case (H#head.mod):slot_objs(H, Slot) of
+ case dets_v9:slot_objs(H, Slot) of
'$end_of_table' -> {H, '$end_of_table'};
[] -> fnext_slot(H, K, Slot+1);
L -> {H, element(H#head.keypos, hd(L))}
@@ -2518,11 +2473,10 @@ fopen2(Fname, Tab) ->
Acc = read_write,
Ram = false,
{ok, Fd, FH} = read_file_header(Fname, Acc, Ram),
- Mod = FH#fileheader.mod,
- Do = case Mod:check_file_header(FH, Fd) of
- {ok, Head1, ExtraInfo} ->
+ Do = case dets_v9:check_file_header(FH, Fd) of
+ {ok, Head1} ->
Head2 = Head1#head{filename = Fname},
- try {ok, Mod:init_freelist(Head2, ExtraInfo)}
+ try {ok, dets_v9:init_freelist(Head2)}
catch
throw:_ ->
{repair, " has bad free lists, repairing ..."}
@@ -2536,8 +2490,7 @@ fopen2(Fname, Tab) ->
case Do of
{repair, Mess} ->
io:format(user, "dets: file ~tp~s~n", [Fname, Mess]),
- Version = default,
- case fsck(Fd, Tab, Fname, FH, default, default, Version) of
+ case fsck(Fd, Tab, Fname, FH, default, default) of
ok ->
fopen2(Fname, Tab);
Error ->
@@ -2570,33 +2523,23 @@ fopen_existing_file(Tab, OpenArgs) ->
#open_args{file = Fname, type = Type, keypos = Kp, repair = Rep,
min_no_slots = MinSlots, max_no_slots = MaxSlots,
ram_file = Ram, delayed_write = CacheSz, auto_save =
- Auto, access = Acc, version = Version, debug = Debug} =
+ Auto, access = Acc, debug = Debug} =
OpenArgs,
{ok, Fd, FH} = read_file_header(Fname, Acc, Ram),
- V9 = (Version =:= 9) or (Version =:= default),
MinF = (MinSlots =:= default) or (MinSlots =:= FH#fileheader.min_no_slots),
MaxF = (MaxSlots =:= default) or (MaxSlots =:= FH#fileheader.max_no_slots),
- Mod = (FH#fileheader.mod),
- Wh = case Mod:check_file_header(FH, Fd) of
- {ok, Head, true} when Rep =:= force, Acc =:= read_write,
- FH#fileheader.version =:= 9,
- FH#fileheader.no_colls =/= undefined,
- MinF, MaxF, V9 ->
- {compact, Head, true};
- {ok, _Head, _Extra} when Rep =:= force, Acc =:= read ->
+ Wh = case dets_v9:check_file_header(FH, Fd) of
+ {ok, Head} when Rep =:= force, Acc =:= read_write,
+ FH#fileheader.no_colls =/= undefined,
+ MinF, MaxF ->
+ {compact, Head};
+ {ok, _Head} when Rep =:= force, Acc =:= read ->
throw({error, {access_mode, Fname}});
- {ok, Head, need_compacting} when Acc =:= read ->
- {final, Head, true}; % Version 8 only.
- {ok, _Head, need_compacting} when Rep =:= true ->
- %% The file needs to be compacted due to a very big
- %% and fragmented free_list. Version 8 only.
- M = " is now compacted ...",
- {repair, M};
- {ok, _Head, _Extra} when Rep =:= force ->
+ {ok, _Head} when Rep =:= force ->
M = ", repair forced.",
{repair, M};
- {ok, Head, ExtraInfo} ->
- {final, Head, ExtraInfo};
+ {ok, Head} ->
+ {final, Head};
{error, not_closed} when Rep =:= force, Acc =:= read_write ->
M = ", repair forced.",
{repair, M};
@@ -2605,17 +2548,13 @@ fopen_existing_file(Tab, OpenArgs) ->
{repair, M};
{error, not_closed} when Rep =:= false ->
throw({error, {needs_repair, Fname}});
- {error, version_bump} when Rep =:= true, Acc =:= read_write ->
- %% Version 8 only
- M = " old version, upgrading ...",
- {repair, M};
{error, Reason} ->
throw({error, {Reason, Fname}})
end,
Do = case Wh of
- {Tag, Hd, Extra} when Tag =:= final; Tag =:= compact ->
+ {Tag, Hd} when Tag =:= final; Tag =:= compact ->
Hd1 = Hd#head{filename = Fname},
- try {Tag, Mod:init_freelist(Hd1, Extra)}
+ try {Tag, dets_v9:init_freelist(Hd1)}
catch
throw:_ ->
{repair, " has bad free lists, repairing ..."}
@@ -2643,23 +2582,20 @@ fopen_existing_file(Tab, OpenArgs) ->
"now repairing ...~n", [Fname]),
{ok, Fd2, _FH} = read_file_header(Fname, Acc, Ram),
do_repair(Fd2, Tab, Fname, FH, MinSlots, MaxSlots,
- Version, OpenArgs)
+ OpenArgs)
end;
{repair, Mess} ->
io:format(user, "dets: file ~tp~s~n", [Fname, Mess]),
do_repair(Fd, Tab, Fname, FH, MinSlots, MaxSlots,
- Version, OpenArgs);
- _ when FH#fileheader.version =/= Version, Version =/= default ->
- throw({error, {version_mismatch, Fname}});
+ OpenArgs);
{final, H} ->
H1 = H#head{auto_save = Auto},
open_final(H1, Fname, Acc, Ram, CacheSz, Tab, Debug)
end.
-do_repair(Fd, Tab, Fname, FH, MinSlots, MaxSlots, Version, OpenArgs) ->
- case fsck(Fd, Tab, Fname, FH, MinSlots, MaxSlots, Version) of
+do_repair(Fd, Tab, Fname, FH, MinSlots, MaxSlots, OpenArgs) ->
+ case fsck(Fd, Tab, Fname, FH, MinSlots, MaxSlots) of
ok ->
- %% No need to update 'version'.
erlang:garbage_collect(),
fopen3(Tab, OpenArgs#open_args{repair = false});
Error ->
@@ -2673,8 +2609,8 @@ open_final(Head, Fname, Acc, Ram, CacheSz, Tab, Debug) ->
filename = Fname,
name = Tab,
cache = dets_utils:new_cache(CacheSz)},
- init_disk_map(Head1#head.version, Tab, Debug),
- (Head1#head.mod):cache_segps(Head1#head.fptr, Fname, Head1#head.next),
+ init_disk_map(Tab, Debug),
+ dets_v9:cache_segps(Head1#head.fptr, Fname, Head1#head.next),
check_growth(Head1),
{ok, Head1}.
@@ -2683,7 +2619,7 @@ fopen_init_file(Tab, OpenArgs) ->
#open_args{file = Fname, type = Type, keypos = Kp,
min_no_slots = MinSlotsArg, max_no_slots = MaxSlotsArg,
ram_file = Ram, delayed_write = CacheSz, auto_save = Auto,
- version = UseVersion, debug = Debug} = OpenArgs,
+ debug = Debug} = OpenArgs,
MinSlots = choose_no_slots(MinSlotsArg, ?DEFAULT_MIN_NO_SLOTS),
MaxSlots = choose_no_slots(MaxSlotsArg, ?DEFAULT_MAX_NO_SLOTS),
FileSpec = if
@@ -2691,20 +2627,11 @@ fopen_init_file(Tab, OpenArgs) ->
true -> Fname
end,
{ok, Fd} = dets_utils:open(FileSpec, open_args(read_write, Ram)),
- Version = if
- UseVersion =:= default ->
- case os:getenv("DETS_USE_FILE_FORMAT") of
- "8" -> 8;
- _ -> 9
- end;
- true ->
- UseVersion
- end,
- Mod = version2module(Version),
%% No need to truncate an empty file.
- init_disk_map(Version, Tab, Debug),
- case catch Mod:initiate_file(Fd, Tab, Fname, Type, Kp, MinSlots, MaxSlots,
- Ram, CacheSz, Auto, true) of
+ init_disk_map(Tab, Debug),
+ case catch dets_v9:initiate_file(Fd, Tab, Fname, Type, Kp,
+ MinSlots, MaxSlots,
+ Ram, CacheSz, Auto, true) of
{error, Reason} when Ram ->
_ = file:close(Fd),
throw({error, Reason});
@@ -2719,15 +2646,13 @@ fopen_init_file(Tab, OpenArgs) ->
end.
%% Debug.
-init_disk_map(9, Name, Debug) ->
+init_disk_map(Name, Debug) ->
case Debug orelse dets_utils:debug_mode() of
true ->
dets_utils:init_disk_map(Name);
false ->
ok
- end;
-init_disk_map(_Version, _Name, _Debug) ->
- ok.
+ end.
open_args(Access, RamFile) ->
A1 = case Access of
@@ -2740,15 +2665,7 @@ open_args(Access, RamFile) ->
end,
A1 ++ A2 ++ [binary, read].
-version2module(V) when V =< 8 -> dets_v8;
-version2module(9) -> dets_v9.
-
-module2version(dets_v8) -> 8;
-module2version(dets_v9) -> 9;
-module2version(not_used) -> 9.
-
%% -> ok | throw(Error)
-%% For version 9 tables only.
compact(SourceHead) ->
#head{name = Tab, filename = Fname, fptr = SFd, type = Type, keypos = Kp,
ram_file = Ram, auto_save = Auto} = SourceHead,
@@ -2759,7 +2676,7 @@ compact(SourceHead) ->
%% It is normally not possible to have two open tables in the same
%% process since the process dictionary is used for caching
%% segment pointers, but here is works anyway--when reading a file
- %% serially the pointers to not need to be used.
+ %% serially the pointers do not need to be used.
Head = case catch dets_v9:prep_table_copy(Fd, Tab, Tmp, Type, Kp, Ram,
CacheSz, Auto, TblParms) of
{ok, H} ->
@@ -2794,7 +2711,7 @@ compact(SourceHead) ->
%% -> ok | Error
%% Closes Fd.
-fsck(Fd, Tab, Fname, FH, MinSlotsArg, MaxSlotsArg, Version) ->
+fsck(Fd, Tab, Fname, FH, MinSlotsArg, MaxSlotsArg) ->
%% MinSlots and MaxSlots are the option values.
#fileheader{min_no_slots = MinSlotsFile,
max_no_slots = MaxSlotsFile} = FH,
@@ -2807,10 +2724,10 @@ fsck(Fd, Tab, Fname, FH, MinSlotsArg, MaxSlotsArg, Version) ->
%% If the number of objects (keys) turns out to be significantly
%% different from NoSlots, we try again with the correct number of
%% objects (keys).
- case fsck_try(Fd, Tab, FH, Fname, SlotNumbers, Version) of
+ case fsck_try(Fd, Tab, FH, Fname, SlotNumbers) of
{try_again, BetterNoSlots} ->
BetterSlotNumbers = {MinSlots, BetterNoSlots, MaxSlots},
- case fsck_try(Fd, Tab, FH, Fname, BetterSlotNumbers, Version) of
+ case fsck_try(Fd, Tab, FH, Fname, BetterSlotNumbers) of
{try_again, _} ->
_ = file:close(Fd),
{error, {cannot_repair, Fname}};
@@ -2829,7 +2746,7 @@ choose_no_slots(NoSlots, _) -> NoSlots.
%% Initiating a table using a fun and repairing (or converting) a
%% file are completely different things, but nevertheless the same
%% method is used in both cases...
-fsck_try(Fd, Tab, FH, Fname, SlotNumbers, Version) ->
+fsck_try(Fd, Tab, FH, Fname, SlotNumbers) ->
Tmp = tempfile(Fname),
#fileheader{type = Type, keypos = KeyPos} = FH,
{_MinSlots, EstNoSlots, MaxSlots} = SlotNumbers,
@@ -2838,7 +2755,7 @@ fsck_try(Fd, Tab, FH, Fname, SlotNumbers, Version) ->
max_no_slots = MaxSlots,
ram_file = false, delayed_write = ?DEFAULT_CACHE,
auto_save = infinity, access = read_write,
- version = Version, debug = false},
+ debug = false},
case catch fopen3(Tab, OpenArgs) of
{ok, Head} ->
case fsck_try_est(Head, Fd, Fname, SlotNumbers, FH) of
@@ -2888,10 +2805,9 @@ assure_no_file(File) ->
%% -> {ok, NewHead} | {try_again, integer()} | Error
fsck_try_est(Head, Fd, Fname, SlotNumbers, FH) ->
%% Mod is the module to use for reading input when repairing.
- Mod = FH#fileheader.mod,
Cntrs = ets:new(dets_repair, []),
- Input = Mod:fsck_input(Head, Fd, Cntrs, FH),
- {Reply, SizeData} = do_sort(Head, SlotNumbers, Input, Cntrs, Fname, Mod),
+ Input = dets_v9:fsck_input(Head, Fd, Cntrs, FH),
+ {Reply, SizeData} = do_sort(Head, SlotNumbers, Input, Cntrs, Fname),
Bulk = false,
case Reply of
{ok, NoDups, H1} ->
@@ -2906,14 +2822,13 @@ fsck_try_est(Head, Fd, Fname, SlotNumbers, FH) ->
Else
end.
-do_sort(Head, SlotNumbers, Input, Cntrs, Fname, Mod) ->
- OldV = module2version(Mod),
+do_sort(Head, SlotNumbers, Input, Cntrs, Fname) ->
%% output_objs/4 replaces {LogSize,NoObjects} in Cntrs by
%% {LogSize,Position,Data,NoObjects | NoCollections}.
%% Data = {FileName,FileDescriptor} | [object()]
- %% For small tables Data may be a list of objects which is more
+ %% For small tables Data can be a list of objects which is more
%% efficient since no temporary files are created.
- Output = (Head#head.mod):output_objs(OldV, Head, SlotNumbers, Cntrs),
+ Output = dets_v9:output_objs(Head, SlotNumbers, Cntrs),
TmpDir = filename:dirname(Fname),
Reply = (catch file_sorter:sort(Input, Output,
[{format, binary},{tmpdir, TmpDir}])),
@@ -2954,13 +2869,6 @@ fsck_copy1([SzData | L], Head, Bulk, NoDups) ->
{ok, Copied} when Copied =:= ExpectedSize;
NoObjects =:= 0 -> % the segments
fsck_copy1(L, Head, Bulk, NoDups);
- {ok, Copied} when Bulk, Head#head.version =:= 8 ->
- NoZeros = ExpectedSize - Copied,
- Dups = NoZeros div Size,
- Addr = Pos+Copied,
- NewHead = free_n_objects(Head, Addr, Size-1, NoDups),
- NewNoDups = NoDups - Dups,
- fsck_copy1(L, NewHead, Bulk, NewNoDups);
{ok, _Copied} -> % should never happen
close_files(Bulk, L, Head),
Reason = if Bulk -> initialization_failed;
@@ -2975,13 +2883,6 @@ fsck_copy1([], Head, _Bulk, NoDups) when NoDups =/= 0 ->
fsck_copy1([], Head, _Bulk, _NoDups) ->
{ok, Head#head{update_mode = dirty}}.
-free_n_objects(Head, _Addr, _Size, 0) ->
- Head;
-free_n_objects(Head, Addr, Size, N) ->
- {NewHead, _} = dets_utils:free(Head, Addr, Size),
- NewAddr = Addr + Size + 1,
- free_n_objects(NewHead, NewAddr, Size, N-1).
-
close_files(false, SizeData, Head) ->
_ = file:close(Head#head.fptr),
close_files(true, SizeData, Head);
@@ -3000,7 +2901,7 @@ close_tmp(Fd) ->
fslot(H, Slot) ->
case catch begin
{NH, []} = write_cache(H),
- Objs = (NH#head.mod):slot_objs(NH, Slot),
+ Objs = dets_v9:slot_objs(NH, Slot),
{NH, Objs}
end of
{NewHead, _Objects} = Reply when is_record(NewHead, head) ->
@@ -3050,7 +2951,7 @@ where_is_object(Head, Object) ->
true ->
case catch write_cache(Head) of
{NewHead, []} ->
- {NewHead, (Head#head.mod):find_object(NewHead, Object)};
+ {NewHead, dets_v9:find_object(NewHead, Object)};
{NewHead, _} = HeadError when is_record(NewHead, head) ->
HeadError
end;
@@ -3063,13 +2964,9 @@ check_objects([T | Ts], Kp) when tuple_size(T) >= Kp ->
check_objects(L, _Kp) ->
L =:= [].
-no_things(Head) when Head#head.no_keys =:= undefined ->
- Head#head.no_objects;
no_things(Head) ->
Head#head.no_keys.
-file_no_things(FH) when FH#fileheader.no_keys =:= undefined ->
- FH#fileheader.no_objects;
file_no_things(FH) ->
FH#fileheader.no_keys.
@@ -3110,7 +3007,7 @@ update_cache(Head, ToAdd) ->
if
Lookup; NewSize >= Cache#cache.tsize ->
%% The cache is considered full, or some lookup.
- {NewHead, LU, PwriteList} = (Head#head.mod):write_cache(Head1),
+ {NewHead, LU, PwriteList} = dets_v9:write_cache(Head1),
{NewHead, Found ++ LU, PwriteList};
NewC =:= [] ->
{Head1, Found, []};
@@ -3195,7 +3092,7 @@ delayed_write(Head, WrTime) ->
%% -> {NewHead, [LookedUpObject]} | throw({NewHead, Error})
write_cache(Head) ->
- {Head1, LU, PwriteList} = (Head#head.mod):write_cache(Head),
+ {Head1, LU, PwriteList} = dets_v9:write_cache(Head),
{NewHead, ok} = dets_utils:pwrite(Head1, PwriteList),
{NewHead, LU}.
@@ -3248,7 +3145,7 @@ scan(Head, C) -> % when is_record(C, dets_cont)
scan(Bin, Head, From, To, L, [], R, {C, Head#head.type}).
scan(Bin, H, From, To, L, Ts, R, {C0, Type} = C) ->
- case (H#head.mod):scan_objs(H, Bin, From, To, L, Ts, R, Type) of
+ case dets_v9:scan_objs(H, Bin, From, To, L, Ts, R, Type) of
{more, NFrom, NTo, NL, NTs, NR, Sz} ->
scan_read(H, NFrom, NTo, Sz, NL, NTs, NR, C);
{stop, <<>>=B, NFrom, NTo, <<>>=NL, NTs} ->
@@ -3305,7 +3202,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,
@@ -3317,7 +3214,7 @@ file_info(FileName) ->
case catch read_file_header(FileName, read, false) of
{ok, Fd, FH} ->
_ = file:close(Fd),
- (FH#fileheader.mod):file_info(FH);
+ dets_v9:file_info(FH);
Other ->
Other
end.
@@ -3332,15 +3229,13 @@ get_head_field(Fd, Field) ->
view(FileName) ->
case catch read_file_header(FileName, read, false) of
{ok, Fd, FH} ->
- Mod = FH#fileheader.mod,
- try Mod:check_file_header(FH, Fd) of
- {ok, H0, ExtraInfo} ->
- Mod = FH#fileheader.mod,
- case Mod:check_file_header(FH, Fd) of
- {ok, H0, ExtraInfo} ->
- H = Mod:init_freelist(H0, ExtraInfo),
+ try dets_v9:check_file_header(FH, Fd) of
+ {ok, H0} ->
+ case dets_v9:check_file_header(FH, Fd) of
+ {ok, H0} ->
+ H = dets_v9:init_freelist(H0),
v_free_list(H),
- Mod:v_segments(H),
+ dets_v9:v_segments(H),
ok;
X ->
X
diff --git a/lib/stdlib/src/dets.hrl b/lib/stdlib/src/dets.hrl
index 6ebeb96156..b5e732b08f 100644
--- a/lib/stdlib/src/dets.hrl
+++ b/lib/stdlib/src/dets.hrl
@@ -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_utils.erl b/lib/stdlib/src/dets_utils.erl
index 34a8ddddaa..da6ebd18f2 100644
--- a/lib/stdlib/src/dets_utils.erl
+++ b/lib/stdlib/src/dets_utils.erl
@@ -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 ->
@@ -478,20 +470,6 @@ new_cache({Delay, Size}) ->
%%% Ullman. I think buddy systems were invented by Knuth, a long
%%% time ago.
-init_slots_from_old_file([{Slot,Addr} | T], Ftab) ->
- init_slot(Slot+1,[{Slot,Addr} | T], Ftab);
-init_slots_from_old_file([], Ftab) ->
- Ftab.
-
-init_slot(_Slot,[], Ftab) ->
- Ftab; % should never happen
-init_slot(_Slot,[{_Addr,0}|T], Ftab) ->
- init_slots_from_old_file(T, Ftab);
-init_slot(Slot,[{_Slot1,Addr}|T], Ftab) ->
- Stree = element(Slot, Ftab),
- %% io:format("init_slot ~p:~p~n",[Slot, Addr]),
- init_slot(Slot,T,setelement(Slot, Ftab, bplus_insert(Stree, Addr))).
-
%%% The free lists are kept in RAM, and written to the end of the file
%%% from time to time. It is possible that a considerable amount of
%%% memory is used for a fragmented file.
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/edlin.erl b/lib/stdlib/src/edlin.erl
index 71e8471c45..64d5a71f3c 100644
--- a/lib/stdlib/src/edlin.erl
+++ b/lib/stdlib/src/edlin.erl
@@ -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),
@@ -401,16 +413,16 @@ do_op(backward_word, Bef0, Aft0, Rs) ->
{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]};
+ {{[],reverse(Bef, [C|Aft])},[{move_rel,-(cp_len(Bef)+1)}|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]};
+ {{reverse(Aft, [C|Bef]),[]},[{move_rel,cp_len(Aft)+1}|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/epp.erl b/lib/stdlib/src/epp.erl
index 40eba4ad67..31d0d499e3 100644
--- a/lib/stdlib/src/epp.erl
+++ b/lib/stdlib/src/epp.erl
@@ -1,7 +1,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 1996-2016. 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.
@@ -194,27 +194,27 @@ 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}) ->
@@ -224,9 +224,9 @@ format_error({illegal_function_usage,Macro}) ->
format_error({'NYI',What}) ->
io_lib:format("not yet implemented '~s'", [What]);
format_error({error,Term}) ->
- io_lib:format("-error(~p).", [Term]);
+ io_lib:format("-error(~tp).", [Term]);
format_error({warning,Term}) ->
- io_lib:format("-warning(~p).", [Term]);
+ io_lib:format("-warning(~tp).", [Term]);
format_error(E) -> file:format_error(E).
-spec parse_file(FileName, IncludePath, PredefMacros) ->
@@ -286,7 +286,7 @@ 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().
@@ -1307,7 +1307,7 @@ expand_macros([{'?',_Lq},Token|_Toks], _St) ->
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], St) ->
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 d32c34dabd..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.
@@ -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,7 +52,11 @@
| {'record', record()}
| {'text', string()}.
+-ifdef(DEBUG).
+-opaque anno() :: [annotation(), ...].
+-else.
-opaque anno() :: location() | [annotation(), ...].
+-endif.
-type anno_term() :: term().
-type column() :: pos_integer().
diff --git a/lib/stdlib/src/erl_compile.erl b/lib/stdlib/src/erl_compile.erl
index a6ae398d03..18d7548fdc 100644
--- a/lib/stdlib/src/erl_compile.erl
+++ b/lib/stdlib/src/erl_compile.erl
@@ -1,7 +1,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 1997-2016. 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.
@@ -181,7 +181,7 @@ parse_generic_option("P", T, #options{specific=Spec}=Opts) ->
parse_generic_option("S", T, #options{specific=Spec}=Opts) ->
compile1(T, Opts#options{specific=['S'|Spec]});
parse_generic_option(Option, _T, _Opts) ->
- io:format(?STDERR, "Unknown option: -~s\n", [Option]),
+ io:format(?STDERR, "Unknown option: -~ts\n", [Option]),
usage().
parse_dep_option("", T) ->
@@ -202,7 +202,7 @@ parse_dep_option("T"++Opt, T0) ->
{Target,T} = get_option("MT", Opt, T0),
{[{makedep_target,Target}],T};
parse_dep_option(Opt, _T) ->
- io:format(?STDERR, "Unknown option: -M~s\n", [Opt]),
+ io:format(?STDERR, "Unknown option: -M~ts\n", [Opt]),
usage().
usage() ->
@@ -337,7 +337,7 @@ file_or_directory(Name) ->
make_term(Str) ->
case erl_scan:string(Str) of
{ok, Tokens, _} ->
- case erl_parse:parse_term(Tokens ++ [{dot, 1}]) of
+ case erl_parse:parse_term(Tokens ++ [{dot, erl_anno:new(1)}]) of
{ok, Term} -> Term;
{error, {_,_,Reason}} ->
io:format(?STDERR, "~ts: ~ts~n", [Reason, Str]),
diff --git a/lib/stdlib/src/erl_expand_records.erl b/lib/stdlib/src/erl_expand_records.erl
index ebcbc54ab1..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-2016. 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,13 +30,13 @@
-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
- strict_ra=[], % strict record accesses
- checked_ra=[] % successfully accessed records
- }).
+-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()],
@@ -46,22 +47,34 @@
%% erl_lint without errors.
module(Fs0, Opts0) ->
Opts = compiler_options(Fs0) ++ Opts0,
- St0 = #exprec{compile = Opts},
+ 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]).
+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),
{[Attr | Fs1], St1};
-forms([{attribute,L,import,Is} | Fs0], St0) ->
- St1 = import(Is, St0),
- {Fs,St2} = forms(Fs0, St1),
- {[{attribute,L,import,Is} | Fs], St2};
forms([{function,L,N,A,Cs0} | Fs0], St0) ->
{Cs,St1} = clauses(Cs0, St0),
{Fs,St2} = forms(Fs0, St1),
@@ -334,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) ->
@@ -352,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),
@@ -470,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),
@@ -502,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);
@@ -769,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}.
@@ -783,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 c08328b4b7..89b97b901e 100644
--- a/lib/stdlib/src/erl_internal.erl
+++ b/lib/stdlib/src/erl_internal.erl
@@ -1,7 +1,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 1998-2016. All Rights Reserved.
+%% Copyright Ericsson AB 1998-2017. All Rights Reserved.
%%
%% Licensed under the Apache License, Version 2.0 (the "License");
%% you may not use this file except in compliance with the License.
@@ -54,6 +54,8 @@
-export([is_type/2]).
+-export([add_predefined_functions/1]).
+
%%---------------------------------------------------------------------------
%% Erlang builtin functions allowed in guards.
@@ -61,42 +63,28 @@
Name :: atom(),
Arity :: arity().
+%% Please keep the alphabetical order.
guard_bif(abs, 1) -> true;
-guard_bif(float, 1) -> true;
-guard_bif(trunc, 1) -> true;
-guard_bif(round, 1) -> true;
-guard_bif(length, 1) -> true;
-guard_bif(hd, 1) -> true;
-guard_bif(tl, 1) -> true;
-guard_bif(size, 1) -> true;
+guard_bif(binary_part, 2) -> true;
+guard_bif(binary_part, 3) -> true;
guard_bif(bit_size, 1) -> true;
guard_bif(byte_size, 1) -> true;
+guard_bif(ceil, 1) -> true;
guard_bif(element, 2) -> true;
-guard_bif(self, 0) -> true;
+guard_bif(float, 1) -> true;
+guard_bif(floor, 1) -> true;
+guard_bif(hd, 1) -> true;
+guard_bif(length, 1) -> true;
guard_bif(map_size, 1) -> true;
guard_bif(node, 0) -> true;
guard_bif(node, 1) -> true;
+guard_bif(round, 1) -> true;
+guard_bif(self, 0) -> true;
+guard_bif(size, 1) -> true;
+guard_bif(tl, 1) -> true;
+guard_bif(trunc, 1) -> true;
guard_bif(tuple_size, 1) -> true;
-guard_bif(is_atom, 1) -> true;
-guard_bif(is_binary, 1) -> true;
-guard_bif(is_bitstring, 1) -> true;
-guard_bif(is_boolean, 1) -> true;
-guard_bif(is_float, 1) -> true;
-guard_bif(is_function, 1) -> true;
-guard_bif(is_function, 2) -> true;
-guard_bif(is_integer, 1) -> true;
-guard_bif(is_list, 1) -> true;
-guard_bif(is_map, 1) -> true;
-guard_bif(is_number, 1) -> true;
-guard_bif(is_pid, 1) -> true;
-guard_bif(is_port, 1) -> true;
-guard_bif(is_reference, 1) -> true;
-guard_bif(is_tuple, 1) -> true;
-guard_bif(is_record, 2) -> true;
-guard_bif(is_record, 3) -> true;
-guard_bif(binary_part, 2) -> true;
-guard_bif(binary_part, 3) -> true;
-guard_bif(Name, A) when is_atom(Name), is_integer(A) -> false.
+guard_bif(Name, A) -> new_type_test(Name, A).
%% Erlang type tests.
-spec type_test(Name, Arity) -> boolean() when
@@ -109,10 +97,11 @@ type_test(Name, Arity) ->
%% Erlang new-style type tests.
-spec new_type_test(Name::atom(), Arity::arity()) -> boolean().
+%% Please keep the alphabetical order.
new_type_test(is_atom, 1) -> true;
-new_type_test(is_boolean, 1) -> true;
new_type_test(is_binary, 1) -> true;
new_type_test(is_bitstring, 1) -> true;
+new_type_test(is_boolean, 1) -> true;
new_type_test(is_float, 1) -> true;
new_type_test(is_function, 1) -> true;
new_type_test(is_function, 2) -> true;
@@ -122,10 +111,10 @@ new_type_test(is_map, 1) -> true;
new_type_test(is_number, 1) -> true;
new_type_test(is_pid, 1) -> true;
new_type_test(is_port, 1) -> true;
-new_type_test(is_reference, 1) -> true;
-new_type_test(is_tuple, 1) -> true;
new_type_test(is_record, 2) -> true;
new_type_test(is_record, 3) -> true;
+new_type_test(is_reference, 1) -> true;
+new_type_test(is_tuple, 1) -> true;
new_type_test(Name, A) when is_atom(Name), is_integer(A) -> false.
%% Erlang old-style type tests.
@@ -271,6 +260,7 @@ bif(bitsize, 1) -> true;
bif(bit_size, 1) -> true;
bif(bitstring_to_list, 1) -> true;
bif(byte_size, 1) -> true;
+bif(ceil, 1) -> true;
bif(check_old_code, 1) -> true;
bif(check_process_code, 2) -> true;
bif(check_process_code, 3) -> true;
@@ -291,6 +281,7 @@ bif(float_to_list, 1) -> true;
bif(float_to_list, 2) -> true;
bif(float_to_binary, 1) -> true;
bif(float_to_binary, 2) -> true;
+bif(floor, 1) -> true;
bif(garbage_collect, 0) -> true;
bif(garbage_collect, 1) -> true;
bif(garbage_collect, 2) -> true;
@@ -340,6 +331,8 @@ bif(list_to_float, 1) -> true;
bif(list_to_integer, 1) -> true;
bif(list_to_integer, 2) -> true;
bif(list_to_pid, 1) -> true;
+bif(list_to_port, 1) -> true;
+bif(list_to_ref, 1) -> true;
bif(list_to_tuple, 1) -> true;
bif(load_module, 2) -> true;
bif(make_ref, 0) -> true;
@@ -357,6 +350,7 @@ bif(nodes, 1) -> true;
bif(now, 0) -> true;
bif(open_port, 2) -> true;
bif(pid_to_list, 1) -> true;
+bif(port_to_list, 1) -> true;
bif(port_close, 1) -> true;
bif(port_command, 2) -> true;
bif(port_command, 3) -> true;
@@ -370,6 +364,7 @@ bif(process_info, 2) -> true;
bif(processes, 0) -> true;
bif(purge_module, 1) -> true;
bif(put, 2) -> true;
+bif(ref_to_list, 1) -> true;
bif(register, 2) -> true;
bif(registered, 0) -> true;
bif(round, 1) -> true;
@@ -584,3 +579,68 @@ is_type(term, 0) -> true;
is_type(timeout, 0) -> true;
is_type(tuple, 0) -> true;
is_type(_, _) -> false.
+
+%%%
+%%% Add and export the pre-defined functions:
+%%%
+%%% module_info/0
+%%% module_info/1
+%%% behaviour_info/1 (optional)
+%%%
+
+-spec add_predefined_functions(Forms) -> UpdatedForms when
+ Forms :: [erl_parse:abstract_form() | erl_parse:form_info()],
+ UpdatedForms :: [erl_parse:abstract_form() | erl_parse:form_info()].
+
+add_predefined_functions(Forms) ->
+ Forms ++ predefined_functions(Forms).
+
+predefined_functions(Forms) ->
+ Attrs = [{Name,Val} || {attribute,_,Name,Val} <- Forms],
+ {module,Mod} = lists:keyfind(module, 1, Attrs),
+ Callbacks = [Callback || {callback,Callback} <- Attrs],
+ OptionalCallbacks = get_optional_callbacks(Attrs),
+ Mpf1 = module_predef_func_beh_info(Callbacks, OptionalCallbacks),
+ Mpf2 = module_predef_funcs_mod_info(Mod),
+ Mpf = [erl_parse:new_anno(F) || F <- Mpf1++Mpf2],
+ Exp = [{F,A} || {function,_,F,A,_} <- Mpf],
+ [{attribute,0,export,Exp}|Mpf].
+
+get_optional_callbacks(Attrs) ->
+ L = [O || {optional_callbacks,O} <- Attrs, is_fa_list(O)],
+ lists:append(L).
+
+is_fa_list([{FuncName, Arity}|L])
+ when is_atom(FuncName), is_integer(Arity), Arity >= 0 ->
+ is_fa_list(L);
+is_fa_list([]) -> true;
+is_fa_list(_) -> false.
+
+module_predef_func_beh_info([], _) ->
+ [];
+module_predef_func_beh_info(Callbacks0, OptionalCallbacks) ->
+ Callbacks = [FA || {{_,_}=FA,_} <- Callbacks0],
+ List = make_list(Callbacks),
+ OptionalList = make_list(OptionalCallbacks),
+ [{function,0,behaviour_info,1,
+ [{clause,0,[{atom,0,callbacks}],[],[List]},
+ {clause,0,[{atom,0,optional_callbacks}],[],[OptionalList]}]}].
+
+make_list([]) -> {nil,0};
+make_list([{Name,Arity}|Rest]) ->
+ {cons,0,
+ {tuple,0,
+ [{atom,0,Name},
+ {integer,0,Arity}]},
+ make_list(Rest)}.
+
+module_predef_funcs_mod_info(Mod) ->
+ ModAtom = {atom,0,Mod},
+ [{function,0,module_info,0,
+ [{clause,0,[],[],
+ [{call,0,{remote,0,{atom,0,erlang},{atom,0,get_module_info}},
+ [ModAtom]}]}]},
+ {function,0,module_info,1,
+ [{clause,0,[{var,0,'X'}],[],
+ [{call,0,{remote,0,{atom,0,erlang},{atom,0,get_module_info}},
+ [ModAtom,{var,0,'X'}]}]}]}].
diff --git a/lib/stdlib/src/erl_lint.erl b/lib/stdlib/src/erl_lint.erl
index e9332ce069..65ba343368 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-2017. All Rights Reserved.
%%
%% Licensed under the Apache License, Version 2.0 (the "License");
%% you may not use this file except in compliance with the License.
@@ -27,7 +27,7 @@
-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]).
@@ -92,6 +92,14 @@ value_option(Flag, Default, On, OnVal, Off, OffVal, Opts) ->
:: dict:dict(ta(), line())
}).
+
+%% Are we outside or inside a catch or try/catch?
+-type catch_scope() :: 'none'
+ | 'after_old_catch'
+ | 'after_try'
+ | 'wrong_part_of_try'
+ | 'try_catch'.
+
%% Define the lint state record.
%% 'called' and 'exports' contain {Line, {Function, Arity}},
%% the other function collections contain {Function, Arity}.
@@ -135,7 +143,9 @@ value_option(Flag, Default, On, OnVal, Off, OffVal, Opts) ->
types = dict:new() %Type definitions
:: dict:dict(ta(), #typeinfo{}),
exp_types=gb_sets:empty() %Exported types
- :: gb_sets:set(ta())
+ :: gb_sets:set(ta()),
+ catch_scope = none %Inside/outside try or catch
+ :: catch_scope()
}).
-type lint_state() :: #lint{}.
@@ -156,6 +166,8 @@ format_error(pmod_unsupported) ->
"parameterized modules are no longer supported";
%% format_error({redefine_mod_import, M, P}) ->
%% io_lib:format("module '~s' already imported from package '~s'", [M, P]);
+format_error(non_latin1_module_unsupported) ->
+ "module names with non-latin1 characters are not supported";
format_error(invalid_call) ->
"invalid function call";
@@ -163,49 +175,48 @@ format_error(invalid_record) ->
"invalid record expression";
format_error({attribute,A}) ->
- io_lib:format("attribute '~w' after function definitions", [A]);
+ io_lib:format("attribute ~tw after function definitions", [A]);
format_error({missing_qlc_hrl,A}) ->
io_lib:format("qlc:q/~w called, but \"qlc.hrl\" not included", [A]);
format_error({redefine_import,{{F,A},M}}) ->
- io_lib:format("function ~w/~w already imported from ~w", [F,A,M]);
+ io_lib:format("function ~tw/~w already imported from ~w", [F,A,M]);
format_error({bad_inline,{F,A}}) ->
- io_lib:format("inlined function ~w/~w undefined", [F,A]);
+ io_lib:format("inlined function ~tw/~w undefined", [F,A]);
format_error({invalid_deprecated,D}) ->
- io_lib:format("badly formed deprecated attribute ~w", [D]);
+ io_lib:format("badly formed deprecated attribute ~tw", [D]);
format_error({bad_deprecated,{F,A}}) ->
- io_lib:format("deprecated function ~w/~w undefined or not exported", [F,A]);
+ io_lib:format("deprecated function ~tw/~w undefined or not exported",
+ [F,A]);
format_error({bad_nowarn_unused_function,{F,A}}) ->
- io_lib:format("function ~w/~w undefined", [F,A]);
+ io_lib:format("function ~tw/~w undefined", [F,A]);
format_error({bad_nowarn_bif_clash,{F,A}}) ->
- io_lib:format("function ~w/~w undefined", [F,A]);
+ io_lib:format("function ~tw/~w undefined", [F,A]);
format_error(disallowed_nowarn_bif_clash) ->
io_lib:format("compile directive nowarn_bif_clash is no longer allowed,~n"
" - use explicit module names or -compile({no_auto_import, [F/A]})", []);
-format_error({bad_nowarn_deprecated_function,{M,F,A}}) ->
- io_lib:format("~w:~w/~w is not a deprecated function", [M,F,A]);
format_error({bad_on_load,Term}) ->
- io_lib:format("badly formed on_load attribute: ~w", [Term]);
+ io_lib:format("badly formed on_load attribute: ~tw", [Term]);
format_error(multiple_on_loads) ->
"more than one on_load attribute";
format_error({bad_on_load_arity,{F,A}}) ->
- io_lib:format("function ~w/~w has wrong arity (must be 0)", [F,A]);
+ io_lib:format("function ~tw/~w has wrong arity (must be 0)", [F,A]);
format_error({undefined_on_load,{F,A}}) ->
- io_lib:format("function ~w/~w undefined", [F,A]);
+ io_lib:format("function ~tw/~w undefined", [F,A]);
format_error(export_all) ->
"export_all flag enabled - all functions will be exported";
format_error({duplicated_export, {F,A}}) ->
- io_lib:format("function ~w/~w already exported", [F,A]);
+ io_lib:format("function ~tw/~w already exported", [F,A]);
format_error({unused_import,{{F,A},M}}) ->
- io_lib:format("import ~w:~w/~w is unused", [M,F,A]);
+ io_lib:format("import ~w:~tw/~w is unused", [M,F,A]);
format_error({undefined_function,{F,A}}) ->
- io_lib:format("function ~w/~w undefined", [F,A]);
+ io_lib:format("function ~tw/~w undefined", [F,A]);
format_error({redefine_function,{F,A}}) ->
- io_lib:format("function ~w/~w already defined", [F,A]);
+ io_lib:format("function ~tw/~w already defined", [F,A]);
format_error({define_import,{F,A}}) ->
- io_lib:format("defining imported function ~w/~w", [F,A]);
+ io_lib:format("defining imported function ~tw/~w", [F,A]);
format_error({unused_function,{F,A}}) ->
- io_lib:format("function ~w/~w is unused", [F,A]);
+ io_lib:format("function ~tw/~w is unused", [F,A]);
format_error({call_to_redefined_bif,{F,A}}) ->
io_lib:format("ambiguous call of overridden auto-imported BIF ~w/~w~n"
" - use erlang:~w/~w or \"-compile({no_auto_import,[~w/~w]}).\" "
@@ -221,7 +232,15 @@ format_error({redefine_old_bif_import,{F,A}}) ->
format_error({redefine_bif_import,{F,A}}) ->
io_lib:format("import directive overrides auto-imported BIF ~w/~w~n"
" - use \"-compile({no_auto_import,[~w/~w]}).\" to resolve name clash", [F,A,F,A]);
-
+format_error({get_stacktrace,wrong_part_of_try}) ->
+ "erlang:get_stacktrace/0 used in the wrong part of 'try' expression. "
+ "(Use it in the block between 'catch' and 'end'.)";
+format_error({get_stacktrace,after_old_catch}) ->
+ "erlang:get_stacktrace/0 used following an old-style 'catch' "
+ "may stop working in a future release. (Use it inside 'try'.)";
+format_error({get_stacktrace,after_try}) ->
+ "erlang:get_stacktrace/0 used following a 'try' expression "
+ "may stop working in a future release. (Use it inside 'try'.)";
format_error({deprecated, MFA, ReplacementMFA, Rel}) ->
io_lib:format("~s is deprecated and will be removed in ~s; use ~s",
[format_mfa(MFA), Rel, format_mfa(ReplacementMFA)]);
@@ -238,7 +257,11 @@ 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]);
@@ -249,7 +272,7 @@ format_error(illegal_bin_pattern) ->
"binary patterns cannot be matched in parallel using '='";
format_error(illegal_expr) -> "illegal expression";
format_error({illegal_guard_local_call, {F,A}}) ->
- io_lib:format("call to local/imported function ~w/~w is illegal in guard",
+ io_lib:format("call to local/imported function ~tw/~w is illegal in guard",
[F,A]);
format_error(illegal_guard_expr) -> "illegal guard expression";
%% --- maps ---
@@ -257,23 +280,23 @@ format_error(illegal_map_construction) ->
"only association operators '=>' are allowed in map construction";
%% --- records ---
format_error({undefined_record,T}) ->
- io_lib:format("record ~w undefined", [T]);
+ io_lib:format("record ~tw undefined", [T]);
format_error({redefine_record,T}) ->
- io_lib:format("record ~w already defined", [T]);
+ io_lib:format("record ~tw already defined", [T]);
format_error({redefine_field,T,F}) ->
- io_lib:format("field ~w already defined in record ~w", [F,T]);
+ io_lib:format("field ~tw already defined in record ~tw", [F,T]);
format_error({undefined_field,T,F}) ->
- io_lib:format("field ~w undefined in record ~w", [F,T]);
+ io_lib:format("field ~tw undefined in record ~tw", [F,T]);
format_error(illegal_record_info) ->
"illegal record info";
format_error({field_name_is_variable,T,F}) ->
- io_lib:format("field ~w is not an atom or _ in record ~w", [F,T]);
+ io_lib:format("field ~tw is not an atom or _ in record ~tw", [F,T]);
format_error({wildcard_in_update,T}) ->
- io_lib:format("meaningless use of _ in update of record ~w", [T]);
+ io_lib:format("meaningless use of _ in update of record ~tw", [T]);
format_error({unused_record,T}) ->
- io_lib:format("record ~w is unused", [T]);
+ io_lib:format("record ~tw is unused", [T]);
format_error({untyped_record,T}) ->
- io_lib:format("record ~w has field(s) without type information", [T]);
+ io_lib:format("record ~tw has field(s) without type information", [T]);
%% --- variables ----
format_error({unbound_var,V}) ->
io_lib:format("variable ~w is unbound", [V]);
@@ -291,7 +314,7 @@ format_error({variable_in_record_def,V}) ->
io_lib:format("variable ~w in record definition", [V]);
%% --- binaries ---
format_error({undefined_bittype,Type}) ->
- io_lib:format("bit type ~w undefined", [Type]);
+ io_lib:format("bit type ~tw undefined", [Type]);
format_error({bittype_mismatch,Val1,Val2,What}) ->
io_lib:format("conflict in ~s specification for bit field: '~p' and '~p'",
[What,Val1,Val2]);
@@ -311,13 +334,13 @@ format_error(unsized_binary_in_bin_gen_pattern) ->
"binary fields without size are not allowed in patterns of bit string generators";
%% --- behaviours ---
format_error({conflicting_behaviours,{Name,Arity},B,FirstL,FirstB}) ->
- io_lib:format("conflicting behaviours - callback ~w/~w required by both '~p' "
+ io_lib:format("conflicting behaviours - callback ~tw/~w required by both '~p' "
"and '~p' ~s", [Name,Arity,B,FirstB,format_where(FirstL)]);
format_error({undefined_behaviour_func, {Func,Arity}, Behaviour}) ->
- io_lib:format("undefined callback function ~w/~w (behaviour '~w')",
+ io_lib:format("undefined callback function ~tw/~w (behaviour '~w')",
[Func,Arity,Behaviour]);
format_error({undefined_behaviour,Behaviour}) ->
- io_lib:format("behaviour ~w undefined", [Behaviour]);
+ io_lib:format("behaviour ~tw undefined", [Behaviour]);
format_error({undefined_behaviour_callbacks,Behaviour}) ->
io_lib:format("behaviour ~w callback functions are undefined",
[Behaviour]);
@@ -328,23 +351,23 @@ format_error({ill_defined_optional_callbacks,Behaviour}) ->
io_lib:format("behaviour ~w optional callback functions erroneously defined",
[Behaviour]);
format_error({behaviour_info, {_M,F,A}}) ->
- io_lib:format("cannot define callback attibute for ~w/~w when "
+ io_lib:format("cannot define callback attibute for ~tw/~w when "
"behaviour_info is defined",[F,A]);
format_error({redefine_optional_callback, {F, A}}) ->
- io_lib:format("optional callback ~w/~w duplicated", [F, A]);
+ io_lib:format("optional callback ~tw/~w duplicated", [F, A]);
format_error({undefined_callback, {_M, F, A}}) ->
- io_lib:format("callback ~w/~w is undefined", [F, A]);
+ io_lib:format("callback ~tw/~w is undefined", [F, A]);
%% --- types and specs ---
format_error({singleton_typevar, Name}) ->
io_lib:format("type variable ~w is only used once (is unbound)", [Name]);
format_error({bad_export_type, _ETs}) ->
io_lib:format("bad export_type declaration", []);
format_error({duplicated_export_type, {T, A}}) ->
- io_lib:format("type ~w/~w already exported", [T, A]);
+ io_lib:format("type ~tw/~w already exported", [T, A]);
format_error({undefined_type, {TypeName, Arity}}) ->
- io_lib:format("type ~w~s undefined", [TypeName, gen_type_paren(Arity)]);
+ io_lib:format("type ~tw~s undefined", [TypeName, gen_type_paren(Arity)]);
format_error({unused_type, {TypeName, Arity}}) ->
- io_lib:format("type ~w~s is unused", [TypeName, gen_type_paren(Arity)]);
+ io_lib:format("type ~tw~s is unused", [TypeName, gen_type_paren(Arity)]);
format_error({new_builtin_type, {TypeName, Arity}}) ->
io_lib:format("type ~w~s is a new builtin type; "
"its (re)definition is allowed only until the next release",
@@ -356,25 +379,26 @@ 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 wrong arity";
format_error(callback_wrong_arity) ->
@@ -393,11 +417,15 @@ format_error({deprecated_builtin_type, {Name, Arity},
"removed in ~s; use ~s",
[Name, Arity, Rel, UseS]);
format_error({not_exported_opaque, {TypeName, Arity}}) ->
- io_lib:format("opaque type ~w~s is not exported",
+ io_lib:format("opaque type ~tw~s is not exported",
[TypeName, gen_type_paren(Arity)]);
format_error({underspecified_opaque, {TypeName, Arity}}) ->
- io_lib:format("opaque type ~w~s is underspecified and therefore meaningless",
+ io_lib:format("opaque type ~tw~s is underspecified and therefore meaningless",
[TypeName, gen_type_paren(Arity)]);
+format_error({bad_dialyzer_attribute,Term}) ->
+ io_lib:format("badly formed dialyzer attribute: ~tw", [Term]);
+format_error({bad_dialyzer_option,Term}) ->
+ io_lib:format("unknown dialyzer warning option: ~tw", [Term]);
%% --- obsolete? unused? ---
format_error({format_error, {Fmt, Args}}) ->
io_lib:format(Fmt, Args).
@@ -522,7 +550,7 @@ start(File, Opts) ->
true, Opts)},
{export_all,
bool_option(warn_export_all, nowarn_export_all,
- false, Opts)},
+ true, Opts)},
{export_vars,
bool_option(warn_export_vars, nowarn_export_vars,
false, Opts)},
@@ -558,7 +586,10 @@ start(File, Opts) ->
false, Opts)},
{missing_spec_all,
bool_option(warn_missing_spec_all, nowarn_missing_spec_all,
- false, Opts)}
+ false, Opts)},
+ {get_stacktrace,
+ bool_option(warn_get_stacktrace, nowarn_get_stacktrace,
+ true, Opts)}
],
Enabled1 = [Category || {Category,true} <- Enabled0],
Enabled = ordsets:from_list(Enabled1),
@@ -729,11 +760,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) ->
@@ -776,8 +813,7 @@ attribute_state(Form, St) ->
%% State'
%% Allow for record, type and opaque type definitions and spec
%% declarations to be intersperced within function definitions.
-%% Dialyzer attributes are also allowed everywhere, but are not
-%% checked at all.
+%% Dialyzer attributes are also allowed everywhere.
function_state({attribute,L,record,{Name,Fields}}, St) ->
record_def(L, Name, Fields, St);
@@ -818,9 +854,10 @@ not_deprecated(Forms, St0) ->
{nowarn_deprecated_function, MFAs0} <- lists:flatten([Args]),
MFA <- lists:flatten([MFAs0])],
Nowarn = [MFA || {MFA,_L} <- MFAsL],
- Bad = [MFAL || {{M,F,A},_L}=MFAL <- MFAsL,
- otp_internal:obsolete(M, F, A) =:= no],
- St1 = func_line_warning(bad_nowarn_deprecated_function, Bad, St0),
+ ML = [{M,L} || {{M,_F,_A},L} <- MFAsL, is_atom(M)],
+ St1 = foldl(fun ({M,L}, St2) ->
+ check_module_name(M, L, St2)
+ end, St0, ML),
St1#lint{not_deprecated = ordsets:from_list(Nowarn)}.
%% The nowarn_bif_clash directive is not only deprecated, it's actually an error from R14A
@@ -863,7 +900,8 @@ post_traversal_check(Forms, St0) ->
StD = check_on_load(StC),
StE = check_unused_records(Forms, StD),
StF = check_local_opaque_types(StE),
- check_callback_information(StF).
+ StG = check_dialyzer_attribute(Forms, StF),
+ check_callback_information(StG).
%% check_behaviour(State0) -> State
%% Check that the behaviour attribute is valid.
@@ -927,7 +965,8 @@ behaviour_callbacks(Line, B, St0) ->
catch
_:_ ->
St1 = add_warning(Line, {undefined_behaviour, B}, St0),
- {[], [], St1}
+ St2 = check_module_name(B, Line, St1),
+ {[], [], St2}
end.
behaviour_missing_callbacks([{{Line,B},Bfs0,OBfs}|T], St0) ->
@@ -1265,7 +1304,8 @@ exports(#lint{compile = Opts, defined = Defs, exports = Es}) ->
-type import() :: {module(), [fa()]} | module().
-spec import(line(), import(), lint_state()) -> lint_state().
-import(Line, {Mod,Fs}, St) ->
+import(Line, {Mod,Fs}, St00) ->
+ St = check_module_name(Mod, Line, St00),
Mfs = ordsets:from_list(Fs),
case check_imports(Line, Mfs, St#lint.imports) of
[] ->
@@ -1381,8 +1421,9 @@ call_function(Line, F, A, #lint{usage=Usage0,called=Cd,func=Func,file=File}=St)
%% function(Line, Name, Arity, Clauses, State) -> State.
function(Line, Name, Arity, Cs, St0) ->
- St1 = define_function(Line, Name, Arity, St0#lint{func={Name,Arity}}),
- clauses(Cs, St1).
+ St1 = St0#lint{func={Name,Arity},catch_scope=none},
+ St2 = define_function(Line, Name, Arity, St1),
+ clauses(Cs, St2).
-spec define_function(line(), atom(), arity(), lint_state()) -> lint_state().
@@ -1765,7 +1806,8 @@ bit_size({atom,_Line,all}, _Vt, St, _Check) -> {all,[],St};
bit_size(Size, Vt, St, Check) ->
%% Try to safely evaluate Size if constant to get size,
%% otherwise just treat it as an expression.
- case is_gexpr(Size, St#lint.records) of
+ Info = is_guard_test2_info(St),
+ case is_gexpr(Size, Info) of
true ->
case erl_eval:partial_eval(Size) of
{integer,_ILn,I} -> {I,[],St};
@@ -2000,77 +2042,104 @@ gexpr_list(Es, Vt, St) ->
%% is_guard_test(Expression) -> boolean().
%% Test if a general expression is a guard test.
+%%
+%% Note: Only use this function in contexts where there can be
+%% no definition of a local function that may override a guard BIF
+%% (for example, in the shell).
-spec is_guard_test(Expr) -> boolean() when
Expr :: erl_parse:abstract_expr().
is_guard_test(E) ->
- is_guard_test2(E, dict:new()).
+ is_guard_test2(E, {dict:new(),fun(_) -> false end}).
%% is_guard_test(Expression, Forms) -> boolean().
is_guard_test(Expression, Forms) ->
+ is_guard_test(Expression, Forms, fun(_) -> false end).
+
+
+%% is_guard_test(Expression, Forms, IsOverridden) -> boolean().
+%% Test if a general expression is a guard test.
+%%
+%% IsOverridden({Name,Arity}) should return 'true' if Name/Arity is
+%% a local or imported function in the module. If the abstract code has
+%% passed through erl_expand_records, any call without an explicit
+%% module is to a local function, so IsOverridden can be defined as:
+%%
+%% fun(_) -> true end
+%%
+-spec is_guard_test(Expr, Forms, IsOverridden) -> boolean() when
+ Expr :: erl_parse:abstract_expr(),
+ Forms :: [erl_parse:abstract_form() | erl_parse:form_info()],
+ IsOverridden :: fun((fa()) -> boolean()).
+
+is_guard_test(Expression, Forms, IsOverridden) ->
RecordAttributes = [A || A = {attribute, _, record, _D} <- Forms],
St0 = foldl(fun(Attr0, St1) ->
Attr = set_file(Attr0, "none"),
attribute_state(Attr, St1)
end, start(), RecordAttributes),
- is_guard_test2(set_file(Expression, "nofile"), St0#lint.records).
+ is_guard_test2(set_file(Expression, "nofile"),
+ {St0#lint.records,IsOverridden}).
%% is_guard_test2(Expression, RecordDefs :: dict:dict()) -> boolean().
-is_guard_test2({call,Line,{atom,Lr,record},[E,A]}, RDs) ->
- is_gexpr({call,Line,{atom,Lr,is_record},[E,A]}, RDs);
-is_guard_test2({call,_Line,{atom,_La,Test},As}=Call, RDs) ->
- case erl_internal:type_test(Test, length(As)) of
- true -> is_gexpr_list(As, RDs);
- false -> is_gexpr(Call, RDs)
- end;
-is_guard_test2(G, RDs) ->
+is_guard_test2({call,Line,{atom,Lr,record},[E,A]}, Info) ->
+ is_gexpr({call,Line,{atom,Lr,is_record},[E,A]}, Info);
+is_guard_test2({call,_Line,{atom,_La,Test},As}=Call, {_,IsOverridden}=Info) ->
+ A = length(As),
+ not IsOverridden({Test,A}) andalso
+ case erl_internal:type_test(Test, A) of
+ true -> is_gexpr_list(As, Info);
+ false -> is_gexpr(Call, Info)
+ end;
+is_guard_test2(G, Info) ->
%%Everything else is a guard expression.
- is_gexpr(G, RDs).
+ is_gexpr(G, Info).
%% is_guard_expr(Expression) -> boolean().
%% Test if an expression is a guard expression.
is_guard_expr(E) -> is_gexpr(E, []).
-is_gexpr({var,_L,_V}, _RDs) -> true;
-is_gexpr({char,_L,_C}, _RDs) -> true;
-is_gexpr({integer,_L,_I}, _RDs) -> true;
-is_gexpr({float,_L,_F}, _RDs) -> true;
-is_gexpr({atom,_L,_A}, _RDs) -> true;
-is_gexpr({string,_L,_S}, _RDs) -> true;
-is_gexpr({nil,_L}, _RDs) -> true;
-is_gexpr({cons,_L,H,T}, RDs) -> is_gexpr_list([H,T], RDs);
-is_gexpr({tuple,_L,Es}, RDs) -> is_gexpr_list(Es, RDs);
-%%is_gexpr({struct,_L,_Tag,Es}, RDs) ->
-%% is_gexpr_list(Es, RDs);
-is_gexpr({record_index,_L,_Name,Field}, RDs) ->
- is_gexpr(Field, RDs);
-is_gexpr({record_field,_L,Rec,_Name,Field}, RDs) ->
- is_gexpr_list([Rec,Field], RDs);
-is_gexpr({record,L,Name,Inits}, RDs) ->
- is_gexpr_fields(Inits, L, Name, RDs);
-is_gexpr({bin,_L,Fs}, RDs) ->
+is_gexpr({var,_L,_V}, _Info) -> true;
+is_gexpr({char,_L,_C}, _Info) -> true;
+is_gexpr({integer,_L,_I}, _Info) -> true;
+is_gexpr({float,_L,_F}, _Info) -> true;
+is_gexpr({atom,_L,_A}, _Info) -> true;
+is_gexpr({string,_L,_S}, _Info) -> true;
+is_gexpr({nil,_L}, _Info) -> true;
+is_gexpr({cons,_L,H,T}, Info) -> is_gexpr_list([H,T], Info);
+is_gexpr({tuple,_L,Es}, Info) -> is_gexpr_list(Es, Info);
+%%is_gexpr({struct,_L,_Tag,Es}, Info) ->
+%% is_gexpr_list(Es, Info);
+is_gexpr({record_index,_L,_Name,Field}, Info) ->
+ is_gexpr(Field, Info);
+is_gexpr({record_field,_L,Rec,_Name,Field}, Info) ->
+ is_gexpr_list([Rec,Field], Info);
+is_gexpr({record,L,Name,Inits}, Info) ->
+ is_gexpr_fields(Inits, L, Name, Info);
+is_gexpr({bin,_L,Fs}, Info) ->
all(fun ({bin_element,_Line,E,Sz,_Ts}) ->
- is_gexpr(E, RDs) and (Sz =:= default orelse is_gexpr(Sz, RDs))
+ is_gexpr(E, Info) and (Sz =:= default orelse is_gexpr(Sz, Info))
end, Fs);
-is_gexpr({call,_L,{atom,_Lf,F},As}, RDs) ->
+is_gexpr({call,_L,{atom,_Lf,F},As}, {_,IsOverridden}=Info) ->
A = length(As),
- erl_internal:guard_bif(F, A) andalso is_gexpr_list(As, RDs);
-is_gexpr({call,_L,{remote,_Lr,{atom,_Lm,erlang},{atom,_Lf,F}},As}, RDs) ->
+ not IsOverridden({F,A}) andalso erl_internal:guard_bif(F, A)
+ andalso is_gexpr_list(As, Info);
+is_gexpr({call,_L,{remote,_Lr,{atom,_Lm,erlang},{atom,_Lf,F}},As}, Info) ->
A = length(As),
(erl_internal:guard_bif(F, A) orelse is_gexpr_op(F, A))
- andalso is_gexpr_list(As, RDs);
-is_gexpr({call,L,{tuple,Lt,[{atom,Lm,erlang},{atom,Lf,F}]},As}, RDs) ->
- is_gexpr({call,L,{remote,Lt,{atom,Lm,erlang},{atom,Lf,F}},As}, RDs);
-is_gexpr({op,_L,Op,A}, RDs) ->
- is_gexpr_op(Op, 1) andalso is_gexpr(A, RDs);
-is_gexpr({op,_L,'andalso',A1,A2}, RDs) ->
- is_gexpr_list([A1,A2], RDs);
-is_gexpr({op,_L,'orelse',A1,A2}, RDs) ->
- is_gexpr_list([A1,A2], RDs);
-is_gexpr({op,_L,Op,A1,A2}, RDs) ->
- is_gexpr_op(Op, 2) andalso is_gexpr_list([A1,A2], RDs);
-is_gexpr(_Other, _RDs) -> false.
+ andalso is_gexpr_list(As, Info);
+is_gexpr({call,L,{tuple,Lt,[{atom,Lm,erlang},{atom,Lf,F}]},As}, Info) ->
+ is_gexpr({call,L,{remote,Lt,{atom,Lm,erlang},{atom,Lf,F}},As}, Info);
+is_gexpr({op,_L,Op,A}, Info) ->
+ is_gexpr_op(Op, 1) andalso is_gexpr(A, Info);
+is_gexpr({op,_L,'andalso',A1,A2}, Info) ->
+ is_gexpr_list([A1,A2], Info);
+is_gexpr({op,_L,'orelse',A1,A2}, Info) ->
+ is_gexpr_list([A1,A2], Info);
+is_gexpr({op,_L,Op,A1,A2}, Info) ->
+ is_gexpr_op(Op, 2) andalso is_gexpr_list([A1,A2], Info);
+is_gexpr(_Other, _Info) -> false.
is_gexpr_op(Op, A) ->
try erl_internal:op_type(Op, A) of
@@ -2082,14 +2151,14 @@ is_gexpr_op(Op, A) ->
catch _:_ -> false
end.
-is_gexpr_list(Es, RDs) -> all(fun (E) -> is_gexpr(E, RDs) end, Es).
+is_gexpr_list(Es, Info) -> all(fun (E) -> is_gexpr(E, Info) end, Es).
-is_gexpr_fields(Fs, L, Name, RDs) ->
+is_gexpr_fields(Fs, L, Name, {RDs,_}=Info) ->
IFs = case dict:find(Name, RDs) of
{ok,{_Line,Fields}} -> Fs ++ init_fields(Fs, L, Fields);
error -> Fs
end,
- all(fun ({record_field,_Lf,_Name,V}) -> is_gexpr(V, RDs);
+ all(fun ({record_field,_Lf,_Name,V}) -> is_gexpr(V, Info);
(_Other) -> false end, IFs).
%% exprs(Sequence, VarTable, State) ->
@@ -2220,11 +2289,18 @@ expr({call,L,{tuple,Lt,[{atom,Lm,erlang},{atom,Lf,is_record}]},As}, Vt, St) ->
expr({call,Line,{remote,_Lr,{atom,_Lm,M},{atom,Lf,F}},As}, Vt, St0) ->
St1 = keyword_warning(Lf, F, St0),
St2 = check_remote_function(Line, M, F, As, St1),
- expr_list(As, Vt, St2);
+ St3 = check_module_name(M, Line, St2),
+ expr_list(As, Vt, St3);
expr({call,Line,{remote,_Lr,M,F},As}, Vt, St0) ->
St1 = keyword_warning(Line, M, St0),
St2 = keyword_warning(Line, F, St1),
- expr_list([M,F|As], Vt, St2);
+ St3 = case M of
+ {atom,Lm,Mod} ->
+ check_module_name(Mod, Lm, St2);
+ _ ->
+ St2
+ end,
+ expr_list([M,F|As], Vt, St3);
expr({call,Line,{atom,La,F},As}, Vt, St0) ->
St1 = keyword_warning(La, F, St0),
{Asvt,St2} = expr_list(As, Vt, St1),
@@ -2286,22 +2362,24 @@ expr({call,Line,F,As}, Vt, St0) ->
expr({'try',Line,Es,Scs,Ccs,As}, Vt, St0) ->
%% Currently, we don't allow any exports because later
%% passes cannot handle exports in combination with 'after'.
- {Evt0,St1} = exprs(Es, Vt, St0),
+ {Evt0,St1} = exprs(Es, Vt, St0#lint{catch_scope=wrong_part_of_try}),
TryLine = {'try',Line},
Uvt = vtunsafe(TryLine, Evt0, Vt),
Evt1 = vtupdate(Uvt, Evt0),
- {Sccs,St2} = icrt_clauses(Scs++Ccs, TryLine, vtupdate(Evt1, Vt), St1),
+ {Sccs,St2} = try_clauses(Scs, Ccs, TryLine,
+ vtupdate(Evt1, Vt), St1),
Rvt0 = Sccs,
Rvt1 = vtupdate(vtunsafe(TryLine, Rvt0, Vt), Rvt0),
Evt2 = vtmerge(Evt1, Rvt1),
{Avt0,St} = exprs(As, vtupdate(Evt2, Vt), St2),
Avt1 = vtupdate(vtunsafe(TryLine, Avt0, Vt), Avt0),
Avt = vtmerge(Evt2, Avt1),
- {Avt,St};
+ {Avt,St#lint{catch_scope=after_try}};
expr({'catch',Line,E}, Vt, St0) ->
%% No new variables added, flag new variables as unsafe.
{Evt,St} = expr(E, Vt, St0),
- {vtupdate(vtunsafe({'catch',Line}, Evt, Vt), Evt),St};
+ {vtupdate(vtunsafe({'catch',Line}, Evt, Vt), Evt),
+ St#lint{catch_scope=after_old_catch}};
expr({match,_Line,P,E}, Vt, St0) ->
{Evt,St1} = expr(E, Vt, St0),
{Pvt,Bvt,St2} = pattern(P, vtupdate(Evt, Vt), St1),
@@ -2738,7 +2816,8 @@ check_type(Types, St) ->
check_type({ann_type, _L, [_Var, 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
@@ -2897,11 +2976,12 @@ 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);
@@ -2913,7 +2993,9 @@ 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)},
@@ -2957,6 +3039,16 @@ is_fa({FuncName, Arity})
when is_atom(FuncName), is_integer(Arity), Arity >= 0 -> true;
is_fa(_) -> false.
+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
@@ -3068,6 +3160,70 @@ check_local_opaque_types(St) ->
end,
dict:fold(FoldFun, St, Ts).
+check_dialyzer_attribute(Forms, St0) ->
+ Vals = [{L,V} ||
+ {attribute,L,dialyzer,Val} <- Forms,
+ V0 <- lists:flatten([Val]),
+ V <- case V0 of
+ {O,F} ->
+ [{A,B} ||
+ A <- lists:flatten([O]),
+ B <- lists:flatten([F])];
+ T -> [T]
+ end],
+ {Wellformed, Bad} =
+ lists:partition(fun ({_,{Option,FA}}) when is_atom(Option) ->
+ is_fa(FA);
+ ({_,Option}) when is_atom(Option) -> true;
+ (_) -> false
+ end, Vals),
+ St1 = foldl(fun ({L,Term}, St) ->
+ add_error(L, {bad_dialyzer_attribute,Term}, St)
+ end, St0, Bad),
+ DefFunctions = (gb_sets:to_list(St0#lint.defined) -- pseudolocals()),
+ Fun = fun ({L,{Option,FA}}, St) ->
+ case is_function_dialyzer_option(Option) of
+ true ->
+ case lists:member(FA, DefFunctions) of
+ true -> St;
+ false ->
+ add_error(L, {undefined_function,FA}, St)
+ end;
+ false ->
+ add_error(L, {bad_dialyzer_option,Option}, St)
+ end;
+ ({L,Option}, St) ->
+ case is_module_dialyzer_option(Option) of
+ true -> St;
+ false ->
+ add_error(L, {bad_dialyzer_option,Option}, St)
+ end
+ end,
+ foldl(Fun, St1, Wellformed).
+
+is_function_dialyzer_option(nowarn_function) -> true;
+is_function_dialyzer_option(Option) ->
+ is_module_dialyzer_option(Option).
+
+is_module_dialyzer_option(Option) ->
+ lists:member(Option,
+ [no_return,no_unused,no_improper_lists,no_fun_app,
+ no_match,no_opaque,no_fail_call,no_contracts,
+ no_behaviours,no_undefined_callbacks,unmatched_returns,
+ error_handling,race_conditions,no_missing_calls,
+ specdiffs,overspecs,underspecs,unknown]).
+
+%% try_catch_clauses(Scs, Ccs, In, ImportVarTable, State) ->
+%% {UpdVt,State}.
+
+try_clauses(Scs, Ccs, In, Vt, St0) ->
+ {Csvt0,St1} = icrt_clauses(Scs, Vt, St0),
+ St2 = St1#lint{catch_scope=try_catch},
+ {Csvt1,St3} = icrt_clauses(Ccs, Vt, St2),
+ Csvt = Csvt0 ++ Csvt1,
+ UpdVt = icrt_export(Csvt, Vt, In, St3),
+ {UpdVt,St3}.
+
%% icrt_clauses(Clauses, In, ImportVarTable, State) ->
%% {UpdVt,State}.
@@ -3193,7 +3349,8 @@ lc_quals([{b_generate,_Line,P,E} | Qs], Vt0, Uvt0, St0) ->
{Vt,Uvt,St} = handle_generator(P,E,Vt0,Uvt0,St1),
lc_quals(Qs, Vt, Uvt, St);
lc_quals([F|Qs], Vt, Uvt, St0) ->
- {Fvt,St1} = case is_guard_test2(F, St0#lint.records) of
+ Info = is_guard_test2_info(St0),
+ {Fvt,St1} = case is_guard_test2(F, Info) of
true -> guard_test(F, Vt, St0);
false -> expr(F, Vt, St0)
end,
@@ -3201,6 +3358,12 @@ lc_quals([F|Qs], Vt, Uvt, St0) ->
lc_quals([], Vt, Uvt, St) ->
{Vt, Uvt, St}.
+is_guard_test2_info(#lint{records=RDs,locals=Locals,imports=Imports}) ->
+ {RDs,fun(FA) ->
+ is_local_function(Locals, FA) orelse
+ is_imported_function(Imports, FA)
+ end}.
+
handle_generator(P,E,Vt,Uvt,St0) ->
{Evt,St1} = expr(E, Vt, St0),
%% Forget variables local to E immediately.
@@ -3545,7 +3708,8 @@ has_wildcard_field([]) -> false.
check_remote_function(Line, M, F, As, St0) ->
St1 = deprecated_function(Line, M, F, As, St0),
St2 = check_qlc_hrl(Line, M, F, As, St1),
- format_function(Line, M, F, As, St2).
+ St3 = check_get_stacktrace(Line, M, F, As, St2),
+ format_function(Line, M, F, As, St3).
%% check_qlc_hrl(Line, ModName, FuncName, [Arg], State) -> State
%% Add warning if qlc:q/1,2 has been called but qlc.hrl has not
@@ -3594,6 +3758,23 @@ deprecated_function(Line, M, F, As, St) ->
St
end.
+check_get_stacktrace(Line, erlang, get_stacktrace, [], St) ->
+ case St of
+ #lint{catch_scope=none} ->
+ St;
+ #lint{catch_scope=try_catch} ->
+ St;
+ #lint{catch_scope=Scope} ->
+ case is_warn_enabled(get_stacktrace, St) of
+ false ->
+ St;
+ true ->
+ add_warning(Line, {get_stacktrace,Scope}, St)
+ end
+ end;
+check_get_stacktrace(_, _, _, _, St) ->
+ St.
+
-dialyzer({no_match, deprecated_type/5}).
deprecated_type(L, M, N, As, St) ->
@@ -3618,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.)
@@ -3761,6 +3952,10 @@ extract_sequence(4, [$t, $p | Fmt], Need) ->
extract_sequence(5, [$p|Fmt], Need);
extract_sequence(4, [$t, $P | Fmt], Need) ->
extract_sequence(5, [$P|Fmt], Need);
+extract_sequence(4, [$t, $w | Fmt], Need) ->
+ extract_sequence(5, [$w|Fmt], Need);
+extract_sequence(4, [$t, $W | Fmt], Need) ->
+ extract_sequence(5, [$W|Fmt], Need);
extract_sequence(4, [$t, C | _Fmt], _Need) ->
{error,"invalid control ~t" ++ [C]};
extract_sequence(4, [$l, $p | Fmt], Need) ->
diff --git a/lib/stdlib/src/erl_parse.yrl b/lib/stdlib/src/erl_parse.yrl
index d2dd2848b5..6e72d64acc 100644
--- a/lib/stdlib/src/erl_parse.yrl
+++ b/lib/stdlib/src/erl_parse.yrl
@@ -33,7 +33,6 @@ list tail
list_comprehension lc_expr lc_exprs
binary_comprehension
tuple
-%struct
record_expr record_tuple record_field record_fields
map_expr map_tuple map_field map_field_assoc map_field_exact map_fields map_key
if_expr if_clause if_clauses case_expr cr_clause cr_clauses receive_expr
@@ -108,9 +107,8 @@ type_sig -> fun_type 'when' type_guards : {type, ?anno('$1'), bounded_fun,
type_guards -> type_guard : ['$1'].
type_guards -> type_guard ',' type_guards : ['$1'|'$3'].
-type_guard -> atom '(' top_types ')' : {type, ?anno('$1'), constraint,
- ['$1', '$3']}.
-type_guard -> var '::' top_type : build_def('$1', '$3').
+type_guard -> atom '(' top_types ')' : build_compat_constraint('$1', '$3').
+type_guard -> var '::' top_type : build_constraint('$1', '$3').
top_types -> top_type : ['$1'].
top_types -> top_type ',' top_types : ['$1'|'$3'].
@@ -269,7 +267,6 @@ expr_max -> binary : '$1'.
expr_max -> list_comprehension : '$1'.
expr_max -> binary_comprehension : '$1'.
expr_max -> tuple : '$1'.
-%%expr_max -> struct : '$1'.
expr_max -> '(' expr ')' : '$2'.
expr_max -> 'begin' exprs 'end' : {block,?anno('$1'),'$2'}.
expr_max -> if_expr : '$1'.
@@ -328,10 +325,6 @@ lc_expr -> binary '<=' expr : {b_generate,?anno('$2'),'$1','$3'}.
tuple -> '{' '}' : {tuple,?anno('$1'),[]}.
tuple -> '{' exprs '}' : {tuple,?anno('$1'),'$2'}.
-
-%%struct -> atom tuple :
-%% {struct,?anno('$1'),element(3, '$1'),element(3, '$2')}.
-
map_expr -> '#' map_tuple :
{map, ?anno('$1'),'$2'}.
map_expr -> expr_max '#' map_tuple :
@@ -517,6 +510,22 @@ comp_op -> '>' : '$1'.
comp_op -> '=:=' : '$1'.
comp_op -> '=/=' : '$1'.
+Header
+"%% This file was automatically generated from the file \"erl_parse.yrl\"."
+"%%"
+"%% Copyright Ericsson AB 1996-2015. All Rights Reserved."
+"%%"
+"%% Licensed under the Apache License, Version 2.0 (the \"License\"); you may"
+"%% not use this file except in compliance with the License. You may obtain"
+"%% a copy of the License at <http://www.apache.org/licenses/LICENSE-2.0>"
+"%%"
+"%% Unless required by applicable law or agreed to in writing, software"
+"%% distributed under the License is distributed on an \"AS IS\" BASIS,"
+"%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied."
+"%% See the License for the specific language governing permissions and"
+"%% limitations under the License."
+"".
+
Erlang code.
-export([parse_form/1,parse_exprs/1,parse_term/1]).
@@ -972,6 +981,16 @@ Erlang code.
%% keep track of annotation info in tokens
-define(anno(Tup), element(2, Tup)).
+%-define(DEBUG, true).
+
+-ifdef(DEBUG).
+%% Assumes that erl_anno has been compiled with DEBUG=true.
+-define(ANNO_CHECK(Tokens),
+ [] = [T || T <- Tokens, not is_list(element(2, T))]).
+-else.
+-define(ANNO_CHECK(Tokens), ok).
+-endif.
+
%% Entry points compatible to old erl_parse.
%% These really suck and are only here until Calle gets multiple
%% entry points working.
@@ -981,10 +1000,15 @@ Erlang code.
AbsForm :: abstract_form(),
ErrorInfo :: error_info().
parse_form([{'-',A1},{atom,A2,spec}|Tokens]) ->
- parse([{'-',A1},{'spec',A2}|Tokens]);
+ NewTokens = [{'-',A1},{'spec',A2}|Tokens],
+ ?ANNO_CHECK(NewTokens),
+ parse(NewTokens);
parse_form([{'-',A1},{atom,A2,callback}|Tokens]) ->
- parse([{'-',A1},{'callback',A2}|Tokens]);
+ NewTokens = [{'-',A1},{'callback',A2}|Tokens],
+ ?ANNO_CHECK(NewTokens),
+ parse(NewTokens);
parse_form(Tokens) ->
+ ?ANNO_CHECK(Tokens),
parse(Tokens).
-spec parse_exprs(Tokens) -> {ok, ExprList} | {error, ErrorInfo} when
@@ -992,6 +1016,7 @@ parse_form(Tokens) ->
ExprList :: [abstract_expr()],
ErrorInfo :: error_info().
parse_exprs(Tokens) ->
+ ?ANNO_CHECK(Tokens),
A = erl_anno:new(0),
case parse([{atom,A,f},{'(',A},{')',A},{'->',A}|Tokens]) of
{ok,{function,_Lf,f,0,[{clause,_Lc,[],[],Exprs}]}} ->
@@ -1004,6 +1029,7 @@ parse_exprs(Tokens) ->
Term :: term(),
ErrorInfo :: error_info().
parse_term(Tokens) ->
+ ?ANNO_CHECK(Tokens),
A = erl_anno:new(0),
case parse([{atom,A,f},{'(',A},{')',A},{'->',A}|Tokens]) of
{ok,{function,_Af,f,0,[{clause,_Ac,[],[],[Expr]}]}} ->
@@ -1026,6 +1052,9 @@ build_typed_attribute({atom,Aa,record},
build_typed_attribute({atom,Aa,Attr},
{type_def, {call,_,{atom,_,TypeName},Args}, Type})
when Attr =:= 'type' ; Attr =:= 'opaque' ->
+ lists:foreach(fun({var, A, '_'}) -> ret_err(A, "bad type variable");
+ (_) -> ok
+ end, Args),
case lists:all(fun({var, _, _}) -> true;
(_) -> false
end, Args) of
@@ -1041,13 +1070,13 @@ 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, _, Mod}, {atom, _, Fun}} ->
+ {Mod, Fun, find_arity_from_specs(TypeSpecs)}
end,
{attribute,Aa,Kind,{NewSpecFun, TypeSpecs}}.
@@ -1061,11 +1090,24 @@ find_arity_from_specs([Spec|_]) ->
{type, _, 'fun', [{type, _, product, Args},_]} = Fun,
length(Args).
-build_def({var, A, '_'}, _Types) ->
+%% The 'is_subtype(V, T)' syntax is not supported as of Erlang/OTP
+%% 19.0, but is kept for backward compatibility.
+build_compat_constraint({atom, _, is_subtype}, [{var, _, _}=LHS, Type]) ->
+ build_constraint(LHS, Type);
+build_compat_constraint({atom, _, is_subtype}, [LHS, _Type]) ->
+ ret_err(?anno(LHS), "bad type variable");
+build_compat_constraint({atom, A, Atom}, _Types) ->
+ ret_err(A, io_lib:format("unsupported constraint ~tw", [Atom])).
+
+build_constraint({atom, _, is_subtype}, [{var, _, _}=LHS, Type]) ->
+ build_constraint(LHS, Type);
+build_constraint({atom, A, Atom}, _Foo) ->
+ ret_err(A, io_lib:format("unsupported constraint ~tw", [Atom]));
+build_constraint({var, A, '_'}, _Types) ->
ret_err(A, "bad type variable");
-build_def(LHS, Types) ->
+build_constraint(LHS, Type) ->
IsSubType = {atom, ?anno(LHS), is_subtype},
- {type, ?anno(LHS), constraint, [IsSubType, [LHS, Types]]}.
+ {type, ?anno(LHS), constraint, [IsSubType, [LHS, Type]]}.
lift_unions(T1, {type, _Aa, union, List}) ->
{type, ?anno(T1), union, [T1|List]};
@@ -1178,7 +1220,7 @@ attribute_farity_map(Args) ->
-spec error_bad_decl(erl_anno:anno(), attributes()) -> no_return().
error_bad_decl(Anno, S) ->
- ret_err(Anno, io_lib:format("bad ~w declaration", [S])).
+ ret_err(Anno, io_lib:format("bad ~tw declaration", [S])).
farity_list({cons,_Ac,{op,_Ao,'/',{atom,_Aa,A},{integer,_Ai,I}},Tail}) ->
[{A,I}|farity_list(Tail)];
@@ -1509,8 +1551,8 @@ type_preop_prec('#') -> {700,800}.
Fun :: fun((Anno) -> NewAnno),
Anno :: erl_anno:anno(),
NewAnno :: erl_anno:anno(),
- Abstr :: erl_parse_tree(),
- NewAbstr :: erl_parse_tree().
+ Abstr :: erl_parse_tree() | form_info(),
+ NewAbstr :: erl_parse_tree() | form_info().
map_anno(F0, Abstr) ->
F = fun(A, Acc) -> {F0(A), Acc} end,
@@ -1524,7 +1566,7 @@ map_anno(F0, Abstr) ->
Acc1 :: term(),
AccIn :: term(),
AccOut :: term(),
- Abstr :: erl_parse_tree().
+ Abstr :: erl_parse_tree() | form_info().
fold_anno(F0, Acc0, Abstr) ->
F = fun(A, Acc) -> {A, F0(A, Acc)} end,
@@ -1539,15 +1581,15 @@ fold_anno(F0, Acc0, Abstr) ->
Acc1 :: term(),
AccIn :: term(),
AccOut :: term(),
- Abstr :: erl_parse_tree(),
- NewAbstr :: erl_parse_tree().
+ 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 :: erl_parse_tree().
+ Abstr :: erl_parse_tree() | form_info().
new_anno(Term) ->
F = fun(L, Acc) -> {erl_anno:new(L), Acc} end,
@@ -1555,14 +1597,14 @@ new_anno(Term) ->
NewAbstr.
-spec anno_to_term(Abstr) -> term() when
- Abstr :: erl_parse_tree().
+ Abstr :: erl_parse_tree() | form_info().
anno_to_term(Abstract) ->
F = fun(Anno, Acc) -> {erl_anno:to_term(Anno), Acc} end,
{NewAbstract, []} = modify_anno1(Abstract, [], F),
NewAbstract.
--spec anno_from_term(Term) -> erl_parse_tree() when
+-spec anno_from_term(Term) -> erl_parse_tree() | form_info() when
Term :: term().
anno_from_term(Term) ->
@@ -1571,19 +1613,6 @@ anno_from_term(Term) ->
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) ->
@@ -1620,6 +1649,8 @@ modify_anno1({warning,W}, Ac, _Mf) ->
{{warning,W},Ac};
modify_anno1({error,W}, Ac, _Mf) ->
{{error,W},Ac};
+modify_anno1({eof,L}, Ac, _Mf) ->
+ {{eof,L},Ac};
%% Expressions.
modify_anno1({clauses,Cs}, Ac, Mf) ->
{Cs1,Ac1} = modify_anno1(Cs, Ac, Mf),
diff --git a/lib/stdlib/src/erl_pp.erl b/lib/stdlib/src/erl_pp.erl
index d30cd508c1..ee5e7a11bf 100644
--- a/lib/stdlib/src/erl_pp.erl
+++ b/lib/stdlib/src/erl_pp.erl
@@ -1,7 +1,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 1996-2016. All Rights Reserved.
+%% Copyright Ericsson AB 1996-2017. All Rights Reserved.
%%
%% Licensed under the Apache License, Version 2.0 (the "License");
%% you may not use this file except in compliance with the License.
@@ -44,13 +44,22 @@
| {encoding, latin1 | unicode | utf8}).
-type(options() :: hook_function() | [option()]).
--record(pp, {string_fun, char_fun}).
+-record(pp, {value_fun, string_fun, char_fun}).
-record(options, {hook, encoding, opts}).
%-define(DEBUG, true).
-ifdef(DEBUG).
+-define(FORM_TEST(T),
+ _ = case T of
+ {eof, _Line} -> ok;
+ {warning, _W} -> ok;
+ {error, _E} -> ok;
+ _ -> ?TEST(T)
+ end).
+-define(EXPRS_TEST(L),
+ [?TEST(E) || E <- L]).
-define(TEST(T),
%% Assumes that erl_anno has been compiled with DEBUG=true.
%% erl_pp does not use the annoations, but test it anyway.
@@ -62,6 +71,8 @@
erlang:error(badarg, [T])
end).
-else.
+-define(FORM_TEST(T), ok).
+-define(EXPRS_TEST(T), ok).
-define(TEST(T), ok).
-endif.
@@ -80,7 +91,7 @@ form(Thing) ->
Options :: options()).
form(Thing, Options) ->
- ?TEST(Thing),
+ ?FORM_TEST(Thing),
State = state(Options),
frmt(lform(Thing, options(Options)), State).
@@ -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) ->
@@ -242,31 +257,30 @@ lattribute({attribute,_Line,Name,Arg}, Opts) ->
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)]);
+ 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)}]);
+ attr(module, [{var,a0(),pname(M)}]);
lattribute(export, Falist, _Opts) ->
- call({var,a0(),"-export"}, [falist(Falist)], 0, options(none));
+ attrib(export, falist(Falist));
lattribute(import, Name, _Opts) when is_list(Name) ->
- attr("import", [{var,a0(),pname(Name)}]);
+ attr(import, [{var,a0(),pname(Name)}]);
lattribute(import, {From,Falist}, _Opts) ->
- attr("import",[{var,a0(),pname(From)},falist(Falist)]);
+ attrib(import, [leaf(pname(From)),falist(Falist)]);
lattribute(export_type, Talist, _Opts) ->
- call({var,a0(),"-export_type"}, [falist(Talist)], 0, options(none));
+ attrib(export_type, falist(Talist));
lattribute(optional_callbacks, Falist, Opts) ->
- ArgL = try falist(Falist)
- catch _:_ -> abstract(Falist, Opts)
- end,
- call({var,a0(),"-optional_callbacks"}, [ArgL], 0, options(none));
+ 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}]);
+ attr(file, [{string,a0(),Name},{integer,a0(),Line}]);
lattribute(record, {Name,Is}, Opts) ->
- Nl = leaf(format("-record(~w,", [Name])),
+ Nl = [leaf("-record("),{atom,Name},$,],
[{first,Nl,record_fields(Is, Opts)},$)];
lattribute(Name, Arg, Options) ->
- attr(write(Name), [abstract(Arg, Options)]).
+ attr(Name, [abstract(Arg, Options)]).
abstract(Arg, #options{encoding = Encoding}) ->
erl_parse:abstract(Arg, [{encoding,Encoding}]).
@@ -329,7 +343,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)).
@@ -371,12 +385,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]}.
@@ -418,7 +432,10 @@ ltypes(Ts, F, Prec) ->
[F(T, Prec) || T <- Ts].
attr(Name, Args) ->
- call({var,a0(),format("-~s", [Name])}, Args, 0, options(none)).
+ {first,[$-,{atom,Name}],args(Args, options(none))}.
+
+attrib(Name, Args) ->
+ {first,[$-,{atom,Name}],[{seq,$(,$),[$,],Args}]}.
pname(['' | As]) ->
[$. | pname(As)];
@@ -430,10 +447,13 @@ pname(A) when is_atom(A) ->
write(A).
falist([]) ->
- {nil,a0()};
-falist([{Name,Arity}|Falist]) ->
- A = a0(),
- {cons,A,{var,A,format("~w/~w", [Name,Arity])},falist(Falist)}.
+ [leaf("[]")];
+falist(Falist) ->
+ L = [begin
+ {Name,Arity} = Fa,
+ [{atom,Name},leaf(format("/~w", [Arity]))]
+ end || Fa <- Falist],
+ [{seq,$[,$],$,,L}].
lfunction({function,_Line,Name,_Arity,Cs}, Opts) ->
Cll = nl_clauses(fun (C, H) -> func_clause(Name, C, H) end, $;, Opts, Cs),
@@ -478,7 +498,7 @@ lexpr({var,_,V}, _, _) -> leaf(format("~ts", [V]));
lexpr({char,_,C}, _, _) -> {char,C};
lexpr({integer,_,N}, _, _) -> leaf(write(N));
lexpr({float,_,F}, _, _) -> leaf(write(F));
-lexpr({atom,_,A}, _, _) -> leaf(write(A));
+lexpr({atom,_,A}, _, _) -> {atom,A};
lexpr({string,_,S}, _, _) -> {string,S};
lexpr({nil,_}, _, _) -> '[]';
lexpr({cons,_,H,T}, _, Opts) ->
@@ -508,7 +528,7 @@ lexpr({record, _, Name, Fs}, Prec, Opts) ->
lexpr({record_field, _, Rec, Name, F}, Prec, Opts) ->
{L,P,R} = inop_prec('#'),
Rl = lexpr(Rec, L, Opts),
- Nl = leaf(format("#~w.", [Name])),
+ Nl = [$#,{atom,Name},$.],
El = [Rl,Nl,lexpr(F, R, Opts)],
maybe_paren(P, Prec, El);
lexpr({record, _, Rec, Name, Fs}, Prec, Opts) ->
@@ -527,12 +547,12 @@ lexpr({record_field, _, Rec, F}, Prec, Opts) ->
maybe_paren(P, Prec, El);
lexpr({map, _, Fs}, Prec, Opts) ->
{P,_R} = preop_prec('#'),
- El = {first,leaf("#"),map_fields(Fs, Opts)},
+ El = {first,$#,map_fields(Fs, Opts)},
maybe_paren(P, Prec, El);
lexpr({map, _, Map, Fs}, Prec, Opts) ->
{L,P,_R} = inop_prec('#'),
Rl = lexpr(Map, L, Opts),
- El = {first,[Rl,leaf("#")],map_fields(Fs, Opts)},
+ El = {first,[Rl,$#],map_fields(Fs, Opts)},
maybe_paren(P, Prec, El);
lexpr({block,_,Es}, _, Opts) ->
{list,[{step,'begin',body(Es, Opts)},'end']};
@@ -552,13 +572,16 @@ lexpr({'receive',_,Cs,To,ToOpt}, _, Opts) ->
{step,'after',Al},
'end']};
lexpr({'fun',_,{function,F,A}}, _Prec, _Opts) ->
- leaf(format("fun ~w/~w", [F,A]));
-lexpr({'fun',_,{function,F,A},Extra}, _Prec, _Opts) ->
- {force_nl,fun_info(Extra),leaf(format("fun ~w/~w", [F,A]))};
-lexpr({'fun',_,{function,M,F,A}}, _Prec, _Opts)
+ [leaf("fun "),{atom,F},leaf(format("/~w", [A]))];
+lexpr({'fun',L,{function,_,_}=Func,Extra}, Prec, Opts) ->
+ {force_nl,fun_info(Extra),lexpr({'fun',L,Func}, Prec, Opts)};
+lexpr({'fun',L,{function,M,F,A}}, Prec, Opts)
when is_atom(M), is_atom(F), is_integer(A) ->
%% For backward compatibility with pre-R15 abstract format.
- leaf(format("fun ~w:~w/~w", [M,F,A]));
+ Mod = erl_parse:abstract(M),
+ Fun = erl_parse:abstract(F),
+ Arity = erl_parse:abstract(A),
+ lexpr({'fun',L,{function,Mod,Fun,Arity}}, Prec, Opts);
lexpr({'fun',_,{function,M,F,A}}, _Prec, Opts) ->
%% New format in R15.
NameItem = lexpr(M, Opts),
@@ -649,7 +672,7 @@ lexpr({bin,_,Fs}, _, Opts) ->
bit_grp(Fs, Opts);
%% Special case for straight values.
lexpr({value,_,Val}, _,_) ->
- leaf(write(Val));
+ {value,Val};
%% Now do the hook.
lexpr(Other, _Precedence, #options{hook = none}) ->
leaf(format("INVALID-FORM:~w:",[Other]));
@@ -665,7 +688,7 @@ call(Name, Args, Prec, Opts) ->
maybe_paren(P, Prec, Item).
fun_info(Extra) ->
- leaf(format("% fun-info: ~w", [Extra])).
+ [leaf("% fun-info: "),{value,Extra}].
%% BITS:
@@ -706,7 +729,7 @@ bit_elem_type(T) ->
%% end of BITS
record_name(Name) ->
- leaf(format("#~w", [Name])).
+ [$#,{atom,Name}].
record_fields(Fs, Opts) ->
tuple(Fs, fun record_field/2, Opts).
@@ -908,8 +931,10 @@ frmt(Item, I, PP) ->
%%% - {force_nl,ExtraInfo,I}: fun-info (a comment) forces linebreak before I.
%%% - {prefer_nl,Sep,IPs}: forces linebreak between Is unlesss negative
%%% indentation.
+%%% - {atom,A}: an atom
%%% - {char,C}: a character
%%% - {string,S}: a string.
+%%% - {value,T}: a term.
%%% - {hook,...}, {ehook,...}: hook expressions.
%%%
%%% list, first, seq, force_nl, and prefer_nl all accept IPs, where each
@@ -970,6 +995,10 @@ f({prefer_nl,Sep,LItems}, I0, ST, WT, PP) ->
true ->
{insert_newlines(CharsSize2L, I0, ST),nsz(lists:last(Sizes), I0)}
end;
+f({value,V}, I, ST, WT, PP) ->
+ f(write_a_value(V, PP), I, ST, WT, PP);
+f({atom,A}, I, ST, WT, PP) ->
+ f(write_an_atom(A, PP), I, ST, WT, PP);
f({char,C}, I, ST, WT, PP) ->
f(write_a_char(C, PP), I, ST, WT, PP);
f({string,S}, I, ST, WT, PP) ->
@@ -1108,6 +1137,12 @@ has_nl([C|Cs]) ->
has_nl([]) ->
false.
+write_a_value(V, PP) ->
+ flat_leaf(write_value(V, PP)).
+
+write_an_atom(A, PP) ->
+ flat_leaf(write_atom(A, PP)).
+
write_a_char(C, PP) ->
flat_leaf(write_char(C, PP)).
@@ -1124,7 +1159,7 @@ write_a_string([], _N, _Len, _PP) ->
write_a_string(S, N, Len, PP) ->
SS = string:sub_string(S, 1, N),
Sl = write_string(SS, PP),
- case (length(Sl) > Len) and (N > ?MIN_SUBSTRING) of
+ case (chars_size(Sl) > Len) and (N > ?MIN_SUBSTRING) of
true ->
write_a_string(S, N-1, Len, PP);
false ->
@@ -1136,11 +1171,17 @@ flat_leaf(S) ->
L = lists:flatten(S),
{leaf,length(L),L}.
+write_value(V, PP) ->
+ (PP#pp.value_fun)(V).
+
+write_atom(A, PP) ->
+ (PP#pp.value_fun)(A).
+
write_string(S, PP) ->
- lists:flatten((PP#pp.string_fun)(S)).
+ (PP#pp.string_fun)(S).
write_char(C, PP) ->
- lists:flatten((PP#pp.char_fun)(C)).
+ (PP#pp.char_fun)(C).
%%
%% Utilities
diff --git a/lib/stdlib/src/erl_tar.erl b/lib/stdlib/src/erl_tar.erl
index a383a0fc67..76f0b38108 100644
--- a/lib/stdlib/src/erl_tar.erl
+++ b/lib/stdlib/src/erl_tar.erl
@@ -1,8 +1,8 @@
%%
%% %CopyrightBegin%
-%%
-%% Copyright Ericsson AB 1997-2016. All Rights Reserved.
-%%
+%%
+%% Copyright Ericsson AB 1997-2017. All Rights Reserved.
+%%
%% Licensed under the Apache License, Version 2.0 (the "License");
%% you may not use this file except in compliance with the License.
%% You may obtain a copy of the License at
@@ -14,191 +14,259 @@
%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
%% See the License for the specific language governing permissions and
%% limitations under the License.
-%%
+%%
%% %CopyrightEnd%
%%
+%% This module implements extraction/creation of tar archives.
+%% It supports reading most common tar formats, namely V7, STAR,
+%% USTAR, GNU, BSD/libarchive, and PAX. It produces archives in USTAR
+%% format, unless it must use PAX headers, in which case it produces PAX
+%% format.
+%%
+%% The following references where used:
+%% http://www.freebsd.org/cgi/man.cgi?query=tar&sektion=5
+%% http://www.gnu.org/software/tar/manual/html_node/Standard.html
+%% http://pubs.opengroup.org/onlinepubs/9699919799/utilities/pax.html
-module(erl_tar).
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-%% Purpose: Unix tar (tape archive) utility.
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
--export([init/3, create/2, create/3, extract/1, extract/2, table/1, table/2,
- open/2, close/1, add/3, add/4,
- t/1, tt/1, format_error/1]).
+-export([init/3,
+ create/2, create/3,
+ extract/1, extract/2,
+ table/1, table/2, t/1, tt/1,
+ open/2, close/1,
+ add/3, add/4,
+ format_error/1]).
-include_lib("kernel/include/file.hrl").
+-include_lib("erl_tar.hrl").
--record(add_opts,
- {read_info, % Fun to use for read file/link info.
- chunk_size = 0, % For file reading when sending to sftp. 0=do not chunk
- verbose = false :: boolean()}). % Verbose on/off.
-
-%% Opens a tar archive.
-
-init(UsrHandle, AccessMode, Fun) when is_function(Fun,2) ->
- {ok, {AccessMode,{tar_descriptor,UsrHandle,Fun}}}.
-
-%%%================================================================
-%%% The open function with friends is to keep the file and binary api of this module
-open(Name, Mode) ->
- case open_mode(Mode) of
- {ok, Access, Raw, Opts} ->
- open1(Name, Access, Raw, Opts);
- {error, Reason} ->
- {error, {Name, Reason}}
- end.
-
-open1({binary,Bin}, read, _Raw, Opts) ->
- case file:open(Bin, [ram,binary,read]) of
- {ok,File} ->
- _ = [ram_file:uncompress(File) || Opts =:= [compressed]],
- init(File,read,file_fun());
- Error ->
- Error
- end;
-open1({file, Fd}, read, _Raw, _Opts) ->
- init(Fd, read, file_fun());
-open1(Name, Access, Raw, Opts) ->
- case file:open(Name, Raw ++ [binary, Access|Opts]) of
- {ok, File} ->
- init(File, Access, file_fun());
- {error, Reason} ->
- {error, {Name, Reason}}
- end.
-
-file_fun() ->
- fun(write, {Fd,Data}) -> file:write(Fd, Data);
- (position, {Fd,Pos}) -> file:position(Fd, Pos);
- (read2, {Fd,Size}) -> file:read(Fd,Size);
- (close, Fd) -> file:close(Fd)
- end.
-
-%%% End of file and binary api (except for open_mode/1 downwards
-%%%================================================================
-
-%% Closes a tar archive.
-
-close({read, File}) ->
- ok = do_close(File);
-close({write, File}) ->
- PadResult = pad_file(File),
- ok = do_close(File),
- PadResult;
-close(_) ->
- {error, einval}.
-
-%% Adds a file to a tape archive.
-
-add(File, Name, Options) ->
- add(File, Name, Name, Options).
-add({write, File}, Name, NameInArchive, Options) ->
- Opts = #add_opts{read_info=fun(F) -> file:read_link_info(F) end},
- add1(File, Name, NameInArchive, add_opts(Options, Opts));
-add({read, _File}, _, _, _) ->
- {error, eacces};
-add(_, _, _, _) ->
- {error, einval}.
-
-add_opts([dereference|T], Opts) ->
- add_opts(T, Opts#add_opts{read_info=fun(F) -> file:read_file_info(F) end});
-add_opts([verbose|T], Opts) ->
- add_opts(T, Opts#add_opts{verbose=true});
-add_opts([{chunks,N}|T], Opts) ->
- add_opts(T, Opts#add_opts{chunk_size=N});
-add_opts([_|T], Opts) ->
- add_opts(T, Opts);
-add_opts([], Opts) ->
- Opts.
-
-%% Creates a tar file Name containing the given files.
-
-create(Name, Filenames) ->
- create(Name, Filenames, []).
-
-%% Creates a tar archive Name containing the given files.
-%% Accepted options: verbose, compressed, cooked
+%% Converts the short error reason to a descriptive string.
+-spec format_error(term()) -> string().
+format_error(invalid_tar_checksum) ->
+ "Checksum failed";
+format_error(bad_header) ->
+ "Unrecognized tar header format";
+format_error({bad_header, Reason}) ->
+ lists:flatten(io_lib:format("Unrecognized tar header format: ~p", [Reason]));
+format_error({invalid_header, negative_size}) ->
+ "Invalid header: negative size";
+format_error(invalid_sparse_header_size) ->
+ "Invalid sparse header: negative size";
+format_error(invalid_sparse_map_entry) ->
+ "Invalid sparse map entry";
+format_error({invalid_sparse_map_entry, Reason}) ->
+ lists:flatten(io_lib:format("Invalid sparse map entry: ~p", [Reason]));
+format_error(invalid_end_of_archive) ->
+ "Invalid end of archive";
+format_error(eof) ->
+ "Unexpected end of file";
+format_error(integer_overflow) ->
+ "Failed to parse numeric: integer overflow";
+format_error({misaligned_read, Pos}) ->
+ lists:flatten(io_lib:format("Read a block which was misaligned: block_size=~p pos=~p",
+ [?BLOCK_SIZE, Pos]));
+format_error(invalid_gnu_1_0_sparsemap) ->
+ "Invalid GNU sparse map (version 1.0)";
+format_error({invalid_gnu_0_1_sparsemap, Format}) ->
+ lists:flatten(io_lib:format("Invalid GNU sparse map (version ~s)", [Format]));
+format_error(unsafe_path) ->
+ "The path points above the current working directory";
+format_error({Name,Reason}) ->
+ lists:flatten(io_lib:format("~ts: ~ts", [Name,format_error(Reason)]));
+format_error(Atom) when is_atom(Atom) ->
+ file:format_error(Atom);
+format_error(Term) ->
+ lists:flatten(io_lib:format("~tp", [Term])).
-create(Name, FileList, Options) ->
- Mode = lists:filter(fun(X) -> (X=:=compressed) or (X=:=cooked)
- end, Options),
- case open(Name, [write|Mode]) of
- {ok, TarFile} ->
- Add = fun({NmInA, NmOrBin}) ->
- add(TarFile, NmOrBin, NmInA, Options);
- (Nm) ->
- add(TarFile, Nm, Nm, Options)
- end,
- Result = foreach_while_ok(Add, FileList),
- case {Result, close(TarFile)} of
- {ok, Res} -> Res;
- {Res, _} -> Res
- end;
- Reason ->
- Reason
- end.
+%% Initializes a new reader given a custom file handle and I/O wrappers
+-spec init(handle(), write | read, file_op()) -> {ok, reader()} | {error, badarg}.
+init(Handle, AccessMode, Fun) when is_function(Fun, 2) ->
+ Reader = #reader{handle=Handle,access=AccessMode,func=Fun},
+ {ok, Pos, Reader2} = do_position(Reader, {cur, 0}),
+ {ok, Reader2#reader{pos=Pos}};
+init(_Handle, _AccessMode, _Fun) ->
+ {error, badarg}.
+%%%================================================================
%% Extracts all files from the tar file Name.
-
+-spec extract(open_handle()) -> ok | {error, term()}.
extract(Name) ->
extract(Name, []).
%% Extracts (all) files from the tar file Name.
-%% Options accepted: keep_old_files, {files, ListOfFilesToExtract}, verbose,
-%% {cwd, AbsoluteDirectory}
+%% Options accepted:
+%% - cooked: Opens the tar file without mode `raw`
+%% - compressed: Uncompresses the tar file when reading
+%% - memory: Returns the tar contents as a list of tuples {Name, Bin}
+%% - keep_old_files: Extracted files will not overwrite the destination
+%% - {files, ListOfFilesToExtract}: Only extract ListOfFilesToExtract
+%% - verbose: Prints verbose information about the extraction,
+%% - {cwd, AbsoluteDir}: Sets the current working directory for the extraction
+-spec extract(open_handle(), [extract_opt()]) ->
+ ok
+ | {ok, [{string(), binary()}]}
+ | {error, term()}.
+extract({binary, Bin}, Opts) when is_list(Opts) ->
+ do_extract({binary, Bin}, Opts);
+extract({file, Fd}, Opts) when is_list(Opts) ->
+ do_extract({file, Fd}, Opts);
+extract(#reader{}=Reader, Opts) when is_list(Opts) ->
+ do_extract(Reader, Opts);
+extract(Name, Opts) when is_list(Name); is_binary(Name), is_list(Opts) ->
+ do_extract(Name, Opts).
+
+do_extract(Handle, Opts) when is_list(Opts) ->
+ Opts2 = extract_opts(Opts),
+ Acc = if Opts2#read_opts.output =:= memory -> []; true -> ok end,
+ foldl_read(Handle, fun extract1/4, Acc, Opts2).
+
+extract1(eof, Reader, _, Acc) when is_list(Acc) ->
+ {ok, {ok, lists:reverse(Acc)}, Reader};
+extract1(eof, Reader, _, leading_slash) ->
+ error_logger:info_msg("erl_tar: removed leading '/' from member names\n"),
+ {ok, ok, Reader};
+extract1(eof, Reader, _, Acc) ->
+ {ok, Acc, Reader};
+extract1(#tar_header{name=Name,size=Size}=Header, Reader0, Opts, Acc0) ->
+ case check_extract(Name, Opts) of
+ true ->
+ case do_read(Reader0, Size) of
+ {ok, Bin, Reader1} ->
+ Acc = extract2(Header, Bin, Opts, Acc0),
+ {ok, Acc, Reader1};
+ {error, _} = Err ->
+ throw(Err)
+ end;
+ false ->
+ {ok, Acc0, skip_file(Reader0)}
+ end.
-extract(Name, Opts) ->
- foldl_read(Name, fun extract1/4, ok, extract_opts(Opts)).
+extract2(Header, Bin, Opts, Acc) ->
+ case write_extracted_element(Header, Bin, Opts) of
+ ok ->
+ case Header of
+ #tar_header{name="/"++_} ->
+ leading_slash;
+ #tar_header{} ->
+ Acc
+ end;
+ {ok, NameBin} when is_list(Acc) ->
+ [NameBin | Acc];
+ {error, _} = Err ->
+ throw(Err)
+ end.
-%% Returns a list of names of the files in the tar file Name.
-%% Options accepted: verbose
+%% Checks if the file Name should be extracted.
+check_extract(_, #read_opts{files=all}) ->
+ true;
+check_extract(Name, #read_opts{files=Files}) ->
+ ordsets:is_element(Name, Files).
+
+%%%================================================================
+%% The following table functions produce a list of information about
+%% the files contained in the archive.
+-type filename() :: string().
+-type typeflag() :: regular | link | symlink |
+ char | block | directory |
+ fifo | reserved | unknown.
+-type mode() :: non_neg_integer().
+-type uid() :: non_neg_integer().
+-type gid() :: non_neg_integer().
+
+-type tar_entry() :: {filename(),
+ typeflag(),
+ non_neg_integer(),
+ tar_time(),
+ mode(),
+ uid(),
+ gid()}.
+%% Returns a list of names of the files in the tar file Name.
+-spec table(open_handle()) -> {ok, [string()]} | {error, term()}.
table(Name) ->
table(Name, []).
%% Returns a list of names of the files in the tar file Name.
%% Options accepted: compressed, verbose, cooked.
-
-table(Name, Opts) ->
+-spec table(open_handle(), [compressed | verbose | cooked]) ->
+ {ok, [tar_entry()]} | {error, term()}.
+table(Name, Opts) when is_list(Opts) ->
foldl_read(Name, fun table1/4, [], table_opts(Opts)).
+table1(eof, Reader, _, Result) ->
+ {ok, {ok, lists:reverse(Result)}, Reader};
+table1(#tar_header{}=Header, Reader, #read_opts{verbose=Verbose}, Result) ->
+ Attrs = table1_attrs(Header, Verbose),
+ Reader2 = skip_file(Reader),
+ {ok, [Attrs|Result], Reader2}.
+%% Extracts attributes relevant to table1's output
+table1_attrs(#tar_header{typeflag=Typeflag,mode=Mode}=Header, true) ->
+ Type = typeflag(Typeflag),
+ Name = Header#tar_header.name,
+ Mtime = Header#tar_header.mtime,
+ Uid = Header#tar_header.uid,
+ Gid = Header#tar_header.gid,
+ Size = Header#tar_header.size,
+ {Name, Type, Size, Mtime, Mode, Uid, Gid};
+table1_attrs(#tar_header{name=Name}, _Verbose) ->
+ Name.
+
+typeflag(?TYPE_REGULAR) -> regular;
+typeflag(?TYPE_REGULAR_A) -> regular;
+typeflag(?TYPE_GNU_SPARSE) -> regular;
+typeflag(?TYPE_CONT) -> regular;
+typeflag(?TYPE_LINK) -> link;
+typeflag(?TYPE_SYMLINK) -> symlink;
+typeflag(?TYPE_CHAR) -> char;
+typeflag(?TYPE_BLOCK) -> block;
+typeflag(?TYPE_DIR) -> directory;
+typeflag(?TYPE_FIFO) -> fifo;
+typeflag(_) -> unknown.
+
+%%%================================================================
%% Comments for printing the contents of a tape archive,
%% meant to be invoked from the shell.
-t(Name) ->
+%% Prints each filename in the archive
+-spec t(file:filename()) -> ok | {error, term()}.
+t(Name) when is_list(Name); is_binary(Name) ->
case table(Name) of
- {ok, List} ->
- lists:foreach(fun(N) -> ok = io:format("~ts\n", [N]) end, List);
- Error ->
- Error
+ {ok, List} ->
+ lists:foreach(fun(N) -> ok = io:format("~ts\n", [N]) end, List);
+ Error ->
+ Error
end.
+%% Prints verbose information about each file in the archive
+-spec tt(open_handle()) -> ok | {error, term()}.
tt(Name) ->
case table(Name, [verbose]) of
- {ok, List} ->
- lists:foreach(fun print_header/1, List);
- Error ->
- Error
+ {ok, List} ->
+ lists:foreach(fun print_header/1, List);
+ Error ->
+ Error
end.
+%% Used by tt/1 to print a tar_entry tuple
+-spec print_header(tar_entry()) -> ok.
print_header({Name, Type, Size, Mtime, Mode, Uid, Gid}) ->
io:format("~s~s ~4w/~-4w ~7w ~s ~s\n",
- [type_to_string(Type), mode_to_string(Mode),
- Uid, Gid, Size, time_to_string(Mtime), Name]).
+ [type_to_string(Type), mode_to_string(Mode),
+ Uid, Gid, Size, time_to_string(Mtime), Name]).
-type_to_string(regular) -> "-";
+type_to_string(regular) -> "-";
type_to_string(directory) -> "d";
-type_to_string(link) -> "l";
-type_to_string(symlink) -> "s";
-type_to_string(char) -> "c";
-type_to_string(block) -> "b";
-type_to_string(fifo) -> "f";
-type_to_string(_) -> "?".
-
+type_to_string(link) -> "l";
+type_to_string(symlink) -> "s";
+type_to_string(char) -> "c";
+type_to_string(block) -> "b";
+type_to_string(fifo) -> "f";
+type_to_string(unknown) -> "?".
+
+%% Converts a numeric mode to its human-readable representation
mode_to_string(Mode) ->
mode_to_string(Mode, "xwrxwrxwr", []).
-
mode_to_string(Mode, [C|T], Acc) when Mode band 1 =:= 1 ->
mode_to_string(Mode bsr 1, T, [C|Acc]);
mode_to_string(Mode, [_|T], Acc) ->
@@ -206,7 +274,13 @@ mode_to_string(Mode, [_|T], Acc) ->
mode_to_string(_, [], Acc) ->
Acc.
-time_to_string({{Y, Mon, Day}, {H, Min, _}}) ->
+%% Converts a tar_time() (POSIX time) to a readable string
+time_to_string(Secs0) ->
+ Epoch = calendar:datetime_to_gregorian_seconds(?EPOCH),
+ Secs = Epoch + Secs0,
+ DateTime0 = calendar:gregorian_seconds_to_datetime(Secs),
+ DateTime = calendar:universal_time_to_local_time(DateTime0),
+ {{Y, Mon, Day}, {H, Min, _}} = DateTime,
io_lib:format("~s ~2w ~s:~s ~w", [month(Mon), Day, two_d(H), two_d(Min), Y]).
two_d(N) ->
@@ -225,809 +299,1607 @@ month(10) -> "Oct";
month(11) -> "Nov";
month(12) -> "Dec".
-%% Converts the short error reason to a descriptive string.
+%%%================================================================
+%% The open function with friends is to keep the file and binary api of this module
+-type open_handle() :: file:filename()
+ | {binary, binary()}
+ | {file, term()}.
+-spec open(open_handle(), [write | compressed | cooked]) ->
+ {ok, reader()} | {error, term()}.
+open({binary, Bin}, Mode) when is_binary(Bin) ->
+ do_open({binary, Bin}, Mode);
+open({file, Fd}, Mode) ->
+ do_open({file, Fd}, Mode);
+open(Name, Mode) when is_list(Name); is_binary(Name) ->
+ do_open(Name, Mode).
+
+do_open(Name, Mode) when is_list(Mode) ->
+ case open_mode(Mode) of
+ {ok, Access, Raw, Opts} ->
+ open1(Name, Access, Raw, Opts);
+ {error, Reason} ->
+ {error, {Name, Reason}}
+ end.
-format_error(bad_header) -> "Bad directory header";
-format_error(eof) -> "Unexpected end of file";
-format_error(symbolic_link_too_long) -> "Symbolic link too long";
-format_error({Name,Reason}) ->
- lists:flatten(io_lib:format("~ts: ~ts", [Name,format_error(Reason)]));
-format_error(Atom) when is_atom(Atom) ->
- file:format_error(Atom);
-format_error(Term) ->
- lists:flatten(io_lib:format("~tp", [Term])).
+open1({binary,Bin}, read, _Raw, Opts) when is_binary(Bin) ->
+ case file:open(Bin, [ram,binary,read]) of
+ {ok,File} ->
+ _ = [ram_file:uncompress(File) || Opts =:= [compressed]],
+ {ok, #reader{handle=File,access=read,func=fun file_op/2}};
+ Error ->
+ Error
+ end;
+open1({file, Fd}, read, _Raw, _Opts) ->
+ Reader = #reader{handle=Fd,access=read,func=fun file_op/2},
+ case do_position(Reader, {cur, 0}) of
+ {ok, Pos, Reader2} ->
+ {ok, Reader2#reader{pos=Pos}};
+ {error, _} = Err ->
+ Err
+ end;
+open1(Name, Access, Raw, Opts) when is_list(Name) or is_binary(Name) ->
+ case file:open(Name, Raw ++ [binary, Access|Opts]) of
+ {ok, File} ->
+ {ok, #reader{handle=File,access=Access,func=fun file_op/2}};
+ {error, Reason} ->
+ {error, {Name, Reason}}
+ end.
+open_mode(Mode) ->
+ open_mode(Mode, false, [raw], []).
+
+open_mode(read, _, Raw, _) ->
+ {ok, read, Raw, []};
+open_mode(write, _, Raw, _) ->
+ {ok, write, Raw, []};
+open_mode([read|Rest], false, Raw, Opts) ->
+ open_mode(Rest, read, Raw, Opts);
+open_mode([write|Rest], false, Raw, Opts) ->
+ open_mode(Rest, write, Raw, Opts);
+open_mode([compressed|Rest], Access, Raw, Opts) ->
+ open_mode(Rest, Access, Raw, [compressed|Opts]);
+open_mode([cooked|Rest], Access, _Raw, Opts) ->
+ open_mode(Rest, Access, [], Opts);
+open_mode([], Access, Raw, Opts) ->
+ {ok, Access, Raw, Opts};
+open_mode(_, _, _, _) ->
+ {error, einval}.
+
+file_op(write, {Fd, Data}) ->
+ file:write(Fd, Data);
+file_op(position, {Fd, Pos}) ->
+ file:position(Fd, Pos);
+file_op(read2, {Fd, Size}) ->
+ file:read(Fd, Size);
+file_op(close, Fd) ->
+ file:close(Fd).
+
+%% Closes a tar archive.
+-spec close(reader()) -> ok | {error, term()}.
+close(#reader{access=read}=Reader) ->
+ ok = do_close(Reader);
+close(#reader{access=write}=Reader) ->
+ {ok, Reader2} = pad_file(Reader),
+ ok = do_close(Reader2),
+ ok;
+close(_) ->
+ {error, einval}.
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-%%%
-%%% Useful definitions (also start of implementation).
-%%%
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-%% Offset for fields in the tar header.
-%% Note that these offsets are ZERO-based as in the POSIX standard
-%% document, while binaries use ONE-base offset. Caveat Programmer.
-
--define(th_name, 0).
--define(th_mode, 100).
--define(th_uid, 108).
--define(th_gid, 116).
--define(th_size, 124).
--define(th_mtime, 136).
--define(th_chksum, 148).
--define(th_typeflag, 156).
--define(th_linkname, 157).
--define(th_magic, 257).
--define(th_version, 263).
--define(th_prefix, 345).
-
-%% Length of these fields.
-
--define(th_name_len, 100).
--define(th_mode_len, 8).
--define(th_uid_len, 8).
--define(th_gid_len, 8).
--define(th_size_len, 12).
--define(th_mtime_len, 12).
--define(th_chksum_len, 8).
--define(th_linkname_len, 100).
--define(th_magic_len, 6).
--define(th_version_len, 2).
--define(th_prefix_len, 167).
-
--record(tar_header,
- {name, % Name of file.
- mode, % Mode bits.
- uid, % User id.
- gid, % Group id.
- size, % Size of file
- mtime, % Last modified (seconds since
- % Jan 1, 1970).
- chksum, % Checksum of header.
- typeflag = [], % Type of file.
- linkname = [], % Name of link.
- filler = [],
- prefix}). % Filename prefix.
-
--define(record_size, 512).
--define(block_size, (512*20)).
-
-
-
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-%%%
-%%% Adding members to a tar archive.
-%%%
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-add1(TarFile, Bin, NameInArchive, Opts) when is_binary(Bin) ->
- Now = calendar:now_to_local_time(erlang:timestamp()),
- Info = #file_info{size = byte_size(Bin),
- type = regular,
- access = read_write,
- atime = Now,
- mtime = Now,
- ctime = Now,
- mode = 8#100644,
- links = 1,
- major_device = 0,
- minor_device = 0,
- inode = 0,
- uid = 0,
- gid = 0},
- Header = create_header(NameInArchive, Info),
- add1(TarFile, NameInArchive, Header, Bin, Opts);
-add1(TarFile, Name, NameInArchive, Opts) ->
- case read_file_and_info(Name, Opts) of
- {ok, Bin, Info} when Info#file_info.type =:= regular ->
- Header = create_header(NameInArchive, Info),
- add1(TarFile, Name, Header, Bin, Opts);
- {ok, PointsTo, Info} when Info#file_info.type =:= symlink ->
- if
- length(PointsTo) > 100 ->
- {error,{PointsTo,symbolic_link_too_long}};
- true ->
- Info2 = Info#file_info{size=0},
- Header = create_header(NameInArchive, Info2, PointsTo),
- add1(TarFile, Name, Header, list_to_binary([]), Opts)
- end;
- {ok, _, Info} when Info#file_info.type =:= directory ->
- add_directory(TarFile, Name, NameInArchive, Info, Opts);
- {ok, _, #file_info{type=Type}} ->
- {error, {bad_file_type, Name, Type}};
- {error, Reason} ->
- {error, {Name, Reason}}
+pad_file(#reader{pos=Pos}=Reader) ->
+ %% There must be at least two zero blocks at the end.
+ PadCurrent = skip_padding(Pos+?BLOCK_SIZE),
+ Padding = <<0:PadCurrent/unit:8>>,
+ do_write(Reader, [Padding, ?ZERO_BLOCK, ?ZERO_BLOCK]).
+
+
+%%%================================================================
+%% Creation/modification of tar archives
+
+%% Creates a tar file Name containing the given files.
+-spec create(file:filename(), filelist()) -> ok | {error, {string(), term()}}.
+create(Name, FileList) when is_list(Name); is_binary(Name) ->
+ create(Name, FileList, []).
+
+%% Creates a tar archive Name containing the given files.
+%% Accepted options: verbose, compressed, cooked
+-spec create(file:filename(), filelist(), [create_opt()]) ->
+ ok | {error, term()} | {error, {string(), term()}}.
+create(Name, FileList, Options) when is_list(Name); is_binary(Name) ->
+ Mode = lists:filter(fun(X) -> (X=:=compressed) or (X=:=cooked)
+ end, Options),
+ case open(Name, [write|Mode]) of
+ {ok, TarFile} ->
+ do_create(TarFile, FileList, Options);
+ {error, _} = Err ->
+ Err
end.
-add1(Tar, Name, Header, chunked, Options) ->
- add_verbose(Options, "a ~ts [chunked ", [Name]),
- try
- ok = do_write(Tar, Header),
- {ok,D} = file:open(Name, [read,binary]),
- {ok,NumBytes} = add_read_write_chunks(D, Tar, Options#add_opts.chunk_size, 0, Options),
- _ = file:close(D),
- ok = do_write(Tar, padding(NumBytes,?record_size))
- of
- ok ->
- add_verbose(Options, "~n", []),
- ok
- catch
- error:{badmatch,{error,Error}} ->
- add_verbose(Options, "~n", []),
- {error,{Name,Error}}
+do_create(TarFile, [], _Opts) ->
+ close(TarFile);
+do_create(TarFile, [{NameInArchive, NameOrBin}|Rest], Opts) ->
+ case add(TarFile, NameOrBin, NameInArchive, Opts) of
+ ok ->
+ do_create(TarFile, Rest, Opts);
+ {error, _} = Err ->
+ _ = close(TarFile),
+ Err
+ end;
+do_create(TarFile, [Name|Rest], Opts) ->
+ case add(TarFile, Name, Name, Opts) of
+ ok ->
+ do_create(TarFile, Rest, Opts);
+ {error, _} = Err ->
+ _ = close(TarFile),
+ Err
+ end.
+
+%% Adds a file to a tape archive.
+-type add_type() :: string()
+ | {string(), string()}
+ | {string(), binary()}.
+-spec add(reader(), add_type(), [add_opt()]) -> ok | {error, term()}.
+add(Reader, {NameInArchive, Name}, Opts)
+ when is_list(NameInArchive), is_list(Name) ->
+ do_add(Reader, Name, NameInArchive, Opts);
+add(Reader, {NameInArchive, Bin}, Opts)
+ when is_list(NameInArchive), is_binary(Bin) ->
+ do_add(Reader, Bin, NameInArchive, Opts);
+add(Reader, Name, Opts) when is_list(Name) ->
+ do_add(Reader, Name, Name, Opts).
+
+
+-spec add(reader(), string() | binary(), string(), [add_opt()]) ->
+ ok | {error, term()}.
+add(Reader, NameOrBin, NameInArchive, Options)
+ when is_list(NameOrBin); is_binary(NameOrBin),
+ is_list(NameInArchive), is_list(Options) ->
+ do_add(Reader, NameOrBin, NameInArchive, Options).
+
+do_add(#reader{access=write}=Reader, Name, NameInArchive, Options)
+ when is_list(NameInArchive), is_list(Options) ->
+ RF = fun(F) -> file:read_link_info(F, [{time, posix}]) end,
+ Opts = #add_opts{read_info=RF},
+ add1(Reader, Name, NameInArchive, add_opts(Options, Opts));
+do_add(#reader{access=read},_,_,_) ->
+ {error, eacces};
+do_add(Reader,_,_,_) ->
+ {error, {badarg, Reader}}.
+
+add_opts([dereference|T], Opts) ->
+ RF = fun(F) -> file:read_file_info(F, [{time, posix}]) end,
+ add_opts(T, Opts#add_opts{read_info=RF});
+add_opts([verbose|T], Opts) ->
+ add_opts(T, Opts#add_opts{verbose=true});
+add_opts([{chunks,N}|T], Opts) ->
+ add_opts(T, Opts#add_opts{chunk_size=N});
+add_opts([_|T], Opts) ->
+ add_opts(T, Opts);
+add_opts([], Opts) ->
+ Opts.
+
+add1(#reader{}=Reader, Name, NameInArchive, #add_opts{read_info=ReadInfo}=Opts)
+ when is_list(Name) ->
+ Res = case ReadInfo(Name) of
+ {error, Reason0} ->
+ {error, {Name, Reason0}};
+ {ok, #file_info{type=symlink}=Fi} ->
+ add_verbose(Opts, "a ~ts~n", [NameInArchive]),
+ {ok, Linkname} = file:read_link(Name),
+ Header = fileinfo_to_header(NameInArchive, Fi, Linkname),
+ add_header(Reader, Header, Opts);
+ {ok, #file_info{type=regular}=Fi} ->
+ add_verbose(Opts, "a ~ts~n", [NameInArchive]),
+ Header = fileinfo_to_header(NameInArchive, Fi, false),
+ {ok, Reader2} = add_header(Reader, Header, Opts),
+ FileSize = Header#tar_header.size,
+ {ok, FileSize, Reader3} = do_copy(Reader2, Name, Opts),
+ Padding = skip_padding(FileSize),
+ Pad = <<0:Padding/unit:8>>,
+ do_write(Reader3, Pad);
+ {ok, #file_info{type=directory}=Fi} ->
+ add_directory(Reader, Name, NameInArchive, Fi, Opts);
+ {ok, #file_info{}=Fi} ->
+ add_verbose(Opts, "a ~ts~n", [NameInArchive]),
+ Header = fileinfo_to_header(NameInArchive, Fi, false),
+ add_header(Reader, Header, Opts)
+ end,
+ case Res of
+ ok -> ok;
+ {ok, _Reader} -> ok;
+ {error, _Reason} = Err -> Err
end;
-add1(Tar, Name, Header, Bin, Options) ->
- add_verbose(Options, "a ~ts~n", [Name]),
- do_write(Tar, [Header, Bin, padding(byte_size(Bin), ?record_size)]).
-
-add_read_write_chunks(D, Tar, ChunkSize, SumNumBytes, Options) ->
- case file:read(D, ChunkSize) of
- {ok,Bin} ->
- ok = do_write(Tar, Bin),
- add_verbose(Options, ".", []),
- add_read_write_chunks(D, Tar, ChunkSize, SumNumBytes+byte_size(Bin), Options);
- eof ->
- add_verbose(Options, "]", []),
- {ok,SumNumBytes};
- Other ->
- Other
+add1(Reader, Bin, NameInArchive, Opts) when is_binary(Bin) ->
+ add_verbose(Opts, "a ~ts~n", [NameInArchive]),
+ Now = os:system_time(seconds),
+ Header = #tar_header{
+ name = NameInArchive,
+ size = byte_size(Bin),
+ typeflag = ?TYPE_REGULAR,
+ atime = Now,
+ mtime = Now,
+ ctime = Now,
+ mode = 8#100644},
+ {ok, Reader2} = add_header(Reader, Header, Opts),
+ Padding = skip_padding(byte_size(Bin)),
+ Data = [Bin, <<0:Padding/unit:8>>],
+ case do_write(Reader2, Data) of
+ {ok, _Reader3} -> ok;
+ {error, Reason} -> {error, {NameInArchive, Reason}}
end.
-add_directory(TarFile, DirName, NameInArchive, Info, Options) ->
+add_directory(Reader, DirName, NameInArchive, Info, Opts) ->
case file:list_dir(DirName) of
- {ok, []} ->
- add_verbose(Options, "a ~ts~n", [DirName]),
- Header = create_header(NameInArchive, Info),
- do_write(TarFile, Header);
- {ok, Files} ->
- Add = fun (File) ->
- add1(TarFile,
- filename:join(DirName, File),
- filename:join(NameInArchive, File),
- Options) end,
- foreach_while_ok(Add, Files);
- {error, Reason} ->
- {error, {DirName, Reason}}
+ {ok, []} ->
+ add_verbose(Opts, "a ~ts~n", [NameInArchive]),
+ Header = fileinfo_to_header(NameInArchive, Info, false),
+ add_header(Reader, Header, Opts);
+ {ok, Files} ->
+ add_verbose(Opts, "a ~ts~n", [NameInArchive]),
+ try add_files(Reader, Files, DirName, NameInArchive, Opts) of
+ ok -> ok;
+ {error, _} = Err -> Err
+ catch
+ throw:{error, {_Name, _Reason}} = Err -> Err;
+ throw:{error, Reason} -> {error, {DirName, Reason}}
+ end;
+ {error, Reason} ->
+ {error, {DirName, Reason}}
end.
-
-%% Creates a header for file in a tar file.
-
-create_header(Name, Info) ->
- create_header(Name, Info, []).
-create_header(Name, #file_info {mode=Mode, uid=Uid, gid=Gid,
- size=Size, mtime=Mtime0, type=Type}, Linkname) ->
- Mtime = posix_time(erlang:localtime_to_universaltime(Mtime0)),
- {Prefix,Suffix} = split_filename(Name),
- H0 = [to_string(Suffix, 100),
- to_octal(Mode, 8),
- to_octal(Uid, 8),
- to_octal(Gid, 8),
- to_octal(Size, ?th_size_len),
- to_octal(Mtime, ?th_mtime_len),
- <<" ">>,
- file_type(Type),
- to_string(Linkname, ?th_linkname_len),
- "ustar",0,
- "00",
- zeroes(?th_prefix-?th_version-?th_version_len),
- to_string(Prefix, ?th_prefix_len)],
- H = list_to_binary(H0),
- 512 = byte_size(H), %Assertion.
- ChksumString = to_octal(checksum(H), 6, [0,$\s]),
- <<Before:?th_chksum/binary,_:?th_chksum_len/binary,After/binary>> = H,
- [Before,ChksumString,After].
-
-file_type(regular) -> $0;
-file_type(symlink) -> $2;
-file_type(directory) -> $5.
-
-to_octal(Int, Count) when Count > 1 ->
- to_octal(Int, Count-1, [0]).
-
-to_octal(_, 0, Result) -> Result;
-to_octal(Int, Count, Result) ->
- to_octal(Int div 8, Count-1, [Int rem 8 + $0|Result]).
-
-to_string(Str0, Count) ->
- Str = case file:native_name_encoding() of
- utf8 ->
- unicode:characters_to_binary(Str0);
- latin1 ->
- list_to_binary(Str0)
- end,
- case byte_size(Str) of
- Size when Size < Count ->
- [Str|zeroes(Count-Size)];
- _ -> Str
+
+add_files(_Reader, [], _Dir, _DirInArchive, _Opts) ->
+ ok;
+add_files(Reader, [Name|Rest], Dir, DirInArchive, #add_opts{read_info=Info}=Opts) ->
+ FullName = filename:join(Dir, Name),
+ NameInArchive = filename:join(DirInArchive, Name),
+ Res = case Info(FullName) of
+ {error, Reason} ->
+ {error, {FullName, Reason}};
+ {ok, #file_info{type=directory}=Fi} ->
+ add_directory(Reader, FullName, NameInArchive, Fi, Opts);
+ {ok, #file_info{type=symlink}=Fi} ->
+ add_verbose(Opts, "a ~ts~n", [NameInArchive]),
+ {ok, Linkname} = file:read_link(FullName),
+ Header = fileinfo_to_header(NameInArchive, Fi, Linkname),
+ add_header(Reader, Header, Opts);
+ {ok, #file_info{type=regular}=Fi} ->
+ add_verbose(Opts, "a ~ts~n", [NameInArchive]),
+ Header = fileinfo_to_header(NameInArchive, Fi, false),
+ {ok, Reader2} = add_header(Reader, Header, Opts),
+ FileSize = Header#tar_header.size,
+ {ok, FileSize, Reader3} = do_copy(Reader2, FullName, Opts),
+ Padding = skip_padding(FileSize),
+ Pad = <<0:Padding/unit:8>>,
+ do_write(Reader3, Pad);
+ {ok, #file_info{}=Fi} ->
+ add_verbose(Opts, "a ~ts~n", [NameInArchive]),
+ Header = fileinfo_to_header(NameInArchive, Fi, false),
+ add_header(Reader, Header, Opts)
+ end,
+ case Res of
+ ok -> add_files(Reader, Rest, Dir, DirInArchive, Opts);
+ {ok, ReaderNext} -> add_files(ReaderNext, Rest, Dir, DirInArchive, Opts);
+ {error, _} = Err -> Err
end.
-%% Pads out end of file.
-
-pad_file(File) ->
- {ok,Position} = do_position(File, {cur,0}),
- %% There must be at least two zero records at the end.
- Fill = case ?block_size - (Position rem ?block_size) of
- Fill0 when Fill0 < 2*?record_size ->
- %% We need to another block here to ensure that there
- %% are at least two zero records at the end.
- Fill0 + ?block_size;
- Fill0 ->
- %% Large enough.
- Fill0
- end,
- do_write(File, zeroes(Fill)).
-
-split_filename(Name) when length(Name) =< ?th_name_len ->
- {"", Name};
-split_filename(Name0) ->
- split_filename(lists:reverse(filename:split(Name0)), [], [], 0).
-
-split_filename([Comp|Rest], Prefix, Suffix, Len)
- when Len+length(Comp) < ?th_name_len ->
- split_filename(Rest, Prefix, [Comp|Suffix], Len+length(Comp)+1);
-split_filename([Comp|Rest], Prefix, Suffix, Len) ->
- split_filename(Rest, [Comp|Prefix], Suffix, Len+length(Comp)+1);
-split_filename([], Prefix, Suffix, _) ->
- {filename:join(Prefix),filename:join(Suffix)}.
-
-
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-%%%
-%%% Retrieving files from a tape archive.
-%%%
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-%% Options used when reading a tar archive.
-
--record(read_opts,
- {cwd :: string(), % Current working directory.
- keep_old_files = false :: boolean(), % Owerwrite or not.
- files = all, % Set of files to extract
- % (or all).
- output = file :: 'file' | 'memory',
- open_mode = [], % Open mode options.
- verbose = false :: boolean()}). % Verbose on/off.
+format_string(String, Size) when length(String) > Size ->
+ throw({error, {write_string, field_too_long}});
+format_string(String, Size) ->
+ Ascii = to_ascii(String),
+ if byte_size(Ascii) < Size ->
+ [Ascii, 0];
+ true ->
+ Ascii
+ end.
-extract_opts(List) ->
- extract_opts(List, default_options()).
+format_octal(Octal) ->
+ iolist_to_binary(io_lib:fwrite("~.8B", [Octal])).
+
+add_header(#reader{}=Reader, #tar_header{}=Header, Opts) ->
+ {ok, Iodata} = build_header(Header, Opts),
+ do_write(Reader, Iodata).
+
+write_to_block(Block, IoData, Start) when is_list(IoData) ->
+ write_to_block(Block, iolist_to_binary(IoData), Start);
+write_to_block(Block, Bin, Start) when is_binary(Bin) ->
+ Size = byte_size(Bin),
+ <<Head:Start/unit:8, _:Size/unit:8, Rest/binary>> = Block,
+ <<Head:Start/unit:8, Bin/binary, Rest/binary>>.
+
+build_header(#tar_header{}=Header, Opts) ->
+ #tar_header{
+ name=Name,
+ mode=Mode,
+ uid=Uid,
+ gid=Gid,
+ size=Size,
+ typeflag=Type,
+ linkname=Linkname,
+ uname=Uname,
+ gname=Gname,
+ devmajor=Devmaj,
+ devminor=Devmin
+ } = Header,
+ Mtime = Header#tar_header.mtime,
+
+ Block0 = ?ZERO_BLOCK,
+ {Block1, Pax0} = write_string(Block0, ?V7_NAME, ?V7_NAME_LEN, Name, ?PAX_PATH, #{}),
+ Block2 = write_octal(Block1, ?V7_MODE, ?V7_MODE_LEN, Mode),
+ {Block3, Pax1} = write_numeric(Block2, ?V7_UID, ?V7_UID_LEN, Uid, ?PAX_UID, Pax0),
+ {Block4, Pax2} = write_numeric(Block3, ?V7_GID, ?V7_GID_LEN, Gid, ?PAX_GID, Pax1),
+ {Block5, Pax3} = write_numeric(Block4, ?V7_SIZE, ?V7_SIZE_LEN, Size, ?PAX_SIZE, Pax2),
+ {Block6, Pax4} = write_numeric(Block5, ?V7_MTIME, ?V7_MTIME_LEN, Mtime, ?PAX_NONE, Pax3),
+ {Block7, Pax5} = write_string(Block6, ?V7_TYPE, ?V7_TYPE_LEN, <<Type>>, ?PAX_NONE, Pax4),
+ {Block8, Pax6} = write_string(Block7, ?V7_LINKNAME, ?V7_LINKNAME_LEN,
+ Linkname, ?PAX_LINKPATH, Pax5),
+ {Block9, Pax7} = write_string(Block8, ?USTAR_UNAME, ?USTAR_UNAME_LEN,
+ Uname, ?PAX_UNAME, Pax6),
+ {Block10, Pax8} = write_string(Block9, ?USTAR_GNAME, ?USTAR_GNAME_LEN,
+ Gname, ?PAX_GNAME, Pax7),
+ {Block11, Pax9} = write_numeric(Block10, ?USTAR_DEVMAJ, ?USTAR_DEVMAJ_LEN,
+ Devmaj, ?PAX_NONE, Pax8),
+ {Block12, Pax10} = write_numeric(Block11, ?USTAR_DEVMIN, ?USTAR_DEVMIN_LEN,
+ Devmin, ?PAX_NONE, Pax9),
+ {Block13, Pax11} = set_path(Block12, Pax10),
+ PaxEntry = case maps:size(Pax11) of
+ 0 -> [];
+ _ -> build_pax_entry(Header, Pax11, Opts)
+ end,
+ Block14 = set_format(Block13, ?FORMAT_USTAR),
+ Block15 = set_checksum(Block14),
+ {ok, [PaxEntry, Block15]}.
+
+set_path(Block0, Pax) ->
+ %% only use ustar header when name is too long
+ case maps:get(?PAX_PATH, Pax, nil) of
+ nil ->
+ {Block0, Pax};
+ PaxPath ->
+ case split_ustar_path(PaxPath) of
+ {ok, UstarName, UstarPrefix} ->
+ {Block1, _} = write_string(Block0, ?V7_NAME, ?V7_NAME_LEN,
+ UstarName, ?PAX_NONE, #{}),
+ {Block2, _} = write_string(Block1, ?USTAR_PREFIX, ?USTAR_PREFIX_LEN,
+ UstarPrefix, ?PAX_NONE, #{}),
+ {Block2, maps:remove(?PAX_PATH, Pax)};
+ false ->
+ {Block0, Pax}
+ end
+ end.
-table_opts(List) ->
- read_opts(List, default_options()).
+set_format(Block0, Format)
+ when Format =:= ?FORMAT_USTAR; Format =:= ?FORMAT_PAX ->
+ Block1 = write_to_block(Block0, ?MAGIC_USTAR, ?USTAR_MAGIC),
+ write_to_block(Block1, ?VERSION_USTAR, ?USTAR_VERSION);
+set_format(_Block, Format) ->
+ throw({error, {invalid_format, Format}}).
+
+set_checksum(Block) ->
+ Checksum = compute_checksum(Block),
+ write_octal(Block, ?V7_CHKSUM, ?V7_CHKSUM_LEN, Checksum).
+
+build_pax_entry(Header, PaxAttrs, Opts) ->
+ Path = Header#tar_header.name,
+ Filename = filename:basename(Path),
+ Dir = filename:dirname(Path),
+ Path2 = filename:join([Dir, "PaxHeaders.0", Filename]),
+ AsciiPath = to_ascii(Path2),
+ Path3 = if byte_size(AsciiPath) > ?V7_NAME_LEN ->
+ binary_part(AsciiPath, 0, ?V7_NAME_LEN - 1);
+ true ->
+ AsciiPath
+ end,
+ Keys = maps:keys(PaxAttrs),
+ SortedKeys = lists:sort(Keys),
+ PaxFile = build_pax_file(SortedKeys, PaxAttrs),
+ Size = byte_size(PaxFile),
+ Padding = (?BLOCK_SIZE -
+ (byte_size(PaxFile) rem ?BLOCK_SIZE)) rem ?BLOCK_SIZE,
+ Pad = <<0:Padding/unit:8>>,
+ PaxHeader = #tar_header{
+ name=unicode:characters_to_list(Path3),
+ size=Size,
+ mtime=Header#tar_header.mtime,
+ atime=Header#tar_header.atime,
+ ctime=Header#tar_header.ctime,
+ typeflag=?TYPE_X_HEADER
+ },
+ {ok, PaxHeaderData} = build_header(PaxHeader, Opts),
+ [PaxHeaderData, PaxFile, Pad].
+
+build_pax_file(Keys, PaxAttrs) ->
+ build_pax_file(Keys, PaxAttrs, []).
+build_pax_file([], _, Acc) ->
+ unicode:characters_to_binary(Acc);
+build_pax_file([K|Rest], Attrs, Acc) ->
+ V = maps:get(K, Attrs),
+ Size = sizeof(K) + sizeof(V) + 3,
+ Size2 = sizeof(Size) + Size,
+ Key = to_string(K),
+ Value = to_string(V),
+ Record = unicode:characters_to_binary(io_lib:format("~B ~ts=~ts\n", [Size2, Key, Value])),
+ if byte_size(Record) =/= Size2 ->
+ Size3 = byte_size(Record),
+ Record2 = io_lib:format("~B ~ts=~ts\n", [Size3, Key, Value]),
+ build_pax_file(Rest, Attrs, [Acc, Record2]);
+ true ->
+ build_pax_file(Rest, Attrs, [Acc, Record])
+ end.
-default_options() ->
- {ok, Cwd} = file:get_cwd(),
- #read_opts{cwd=Cwd}.
+sizeof(Bin) when is_binary(Bin) ->
+ byte_size(Bin);
+sizeof(List) when is_list(List) ->
+ length(List);
+sizeof(N) when is_integer(N) ->
+ byte_size(integer_to_binary(N));
+sizeof(N) when is_float(N) ->
+ byte_size(float_to_binary(N)).
+
+to_string(Bin) when is_binary(Bin) ->
+ unicode:characters_to_list(Bin);
+to_string(List) when is_list(List) ->
+ List;
+to_string(N) when is_integer(N) ->
+ integer_to_list(N);
+to_string(N) when is_float(N) ->
+ float_to_list(N).
+
+split_ustar_path(Path) ->
+ Len = length(Path),
+ NotAscii = not is_ascii(Path),
+ if Len =< ?V7_NAME_LEN; NotAscii ->
+ false;
+ true ->
+ PathBin = binary:list_to_bin(Path),
+ case binary:split(PathBin, [<<$/>>], [global, trim_all]) of
+ [Part] when byte_size(Part) >= ?V7_NAME_LEN ->
+ false;
+ Parts ->
+ case lists:last(Parts) of
+ Name when byte_size(Name) >= ?V7_NAME_LEN ->
+ false;
+ Name ->
+ Parts2 = lists:sublist(Parts, length(Parts) - 1),
+ join_split_ustar_path(Parts2, {ok, Name, nil})
+ end
+ end
+ end.
-%% Parse options for extract.
+join_split_ustar_path([], Acc) ->
+ Acc;
+join_split_ustar_path([Part|_], {ok, _, nil})
+ when byte_size(Part) > ?USTAR_PREFIX_LEN ->
+ false;
+join_split_ustar_path([Part|_], {ok, _Name, Acc})
+ when (byte_size(Part)+byte_size(Acc)) > ?USTAR_PREFIX_LEN ->
+ false;
+join_split_ustar_path([Part|Rest], {ok, Name, nil}) ->
+ join_split_ustar_path(Rest, {ok, Name, Part});
+join_split_ustar_path([Part|Rest], {ok, Name, Acc}) ->
+ join_split_ustar_path(Rest, {ok, Name, <<Acc/binary,$/,Part/binary>>}).
+
+write_octal(Block, Pos, Size, X) ->
+ Octal = zero_pad(format_octal(X), Size-1),
+ if byte_size(Octal) < Size ->
+ write_to_block(Block, Octal, Pos);
+ true ->
+ throw({error, {write_failed, octal_field_too_long}})
+ end.
-extract_opts([keep_old_files|Rest], Opts) ->
- extract_opts(Rest, Opts#read_opts{keep_old_files=true});
-extract_opts([{cwd, Cwd}|Rest], Opts) ->
- extract_opts(Rest, Opts#read_opts{cwd=Cwd});
-extract_opts([{files, Files}|Rest], Opts) ->
- Set = ordsets:from_list(Files),
- extract_opts(Rest, Opts#read_opts{files=Set});
-extract_opts([memory|Rest], Opts) ->
- extract_opts(Rest, Opts#read_opts{output=memory});
-extract_opts([compressed|Rest], Opts=#read_opts{open_mode=OpenMode}) ->
- extract_opts(Rest, Opts#read_opts{open_mode=[compressed|OpenMode]});
-extract_opts([cooked|Rest], Opts=#read_opts{open_mode=OpenMode}) ->
- extract_opts(Rest, Opts#read_opts{open_mode=[cooked|OpenMode]});
-extract_opts([verbose|Rest], Opts) ->
- extract_opts(Rest, Opts#read_opts{verbose=true});
-extract_opts([Other|Rest], Opts) ->
- extract_opts(Rest, read_opts([Other], Opts));
-extract_opts([], Opts) ->
- Opts.
+write_string(Block, Pos, Size, Str, PaxAttr, Pax0) ->
+ NotAscii = not is_ascii(Str),
+ if PaxAttr =/= ?PAX_NONE andalso (length(Str) > Size orelse NotAscii) ->
+ Pax1 = maps:put(PaxAttr, Str, Pax0),
+ {Block, Pax1};
+ true ->
+ Formatted = format_string(Str, Size),
+ {write_to_block(Block, Formatted, Pos), Pax0}
+ end.
+write_numeric(Block, Pos, Size, X, PaxAttr, Pax0) ->
+ %% attempt octal
+ Octal = zero_pad(format_octal(X), Size-1),
+ if byte_size(Octal) < Size ->
+ {write_to_block(Block, [Octal, 0], Pos), Pax0};
+ PaxAttr =/= ?PAX_NONE ->
+ Pax1 = maps:put(PaxAttr, X, Pax0),
+ {Block, Pax1};
+ true ->
+ throw({error, {write_failed, numeric_field_too_long}})
+ end.
-%% Common options for all read operations.
+zero_pad(Str, Size) when byte_size(Str) >= Size ->
+ Str;
+zero_pad(Str, Size) ->
+ Padding = Size - byte_size(Str),
+ Pad = binary:copy(<<$0>>, Padding),
+ <<Pad/binary, Str/binary>>.
-read_opts([compressed|Rest], Opts=#read_opts{open_mode=OpenMode}) ->
- read_opts(Rest, Opts#read_opts{open_mode=[compressed|OpenMode]});
-read_opts([cooked|Rest], Opts=#read_opts{open_mode=OpenMode}) ->
- read_opts(Rest, Opts#read_opts{open_mode=[cooked|OpenMode]});
-read_opts([verbose|Rest], Opts) ->
- read_opts(Rest, Opts#read_opts{verbose=true});
-read_opts([_|Rest], Opts) ->
- read_opts(Rest, Opts);
-read_opts([], Opts) ->
- Opts.
-foldl_read({AccessMode,TD={tar_descriptor,_UsrHandle,_AccessFun}}, Fun, Accu, Opts) ->
- case AccessMode of
- read ->
- foldl_read0(TD, Fun, Accu, Opts);
- _ ->
- {error,{read_mode_expected,AccessMode}}
- end;
-foldl_read(TarName, Fun, Accu, Opts) ->
- case open(TarName, [read|Opts#read_opts.open_mode]) of
- {ok, {read, File}} ->
- Result = foldl_read0(File, Fun, Accu, Opts),
- ok = do_close(File),
- Result;
- Error ->
- Error
+%%%================================================================
+%% Functions for creating or modifying tar archives
+
+read_block(Reader) ->
+ case do_read(Reader, ?BLOCK_SIZE) of
+ eof ->
+ throw({error, eof});
+ %% Two zero blocks mark the end of the archive
+ {ok, ?ZERO_BLOCK, Reader1} ->
+ case do_read(Reader1, ?BLOCK_SIZE) of
+ eof ->
+ % This is technically a malformed end-of-archive marker,
+ % as two ZERO_BLOCKs are expected as the marker,
+ % but if we've already made it this far, we should just ignore it
+ eof;
+ {ok, ?ZERO_BLOCK, _Reader2} ->
+ eof;
+ {ok, _Block, _Reader2} ->
+ throw({error, invalid_end_of_archive});
+ {error,_} = Err ->
+ throw(Err)
+ end;
+ {ok, Block, Reader1} when is_binary(Block) ->
+ {ok, Block, Reader1};
+ {error, _} = Err ->
+ throw(Err)
end.
-foldl_read0(File, Fun, Accu, Opts) ->
- case catch foldl_read1(Fun, Accu, File, Opts) of
- {'EXIT', Reason} ->
- exit(Reason);
- {error, {Reason, Format, Args}} ->
- read_verbose(Opts, Format, Args),
- {error, Reason};
- {error, Reason} ->
- {error, Reason};
- Ok ->
- Ok
+get_header(#reader{}=Reader) ->
+ case read_block(Reader) of
+ eof ->
+ eof;
+ {ok, Block, Reader1} ->
+ convert_header(Block, Reader1)
end.
-foldl_read1(Fun, Accu0, File, Opts) ->
- case get_header(File) of
- eof ->
- Fun(eof, File, Opts, Accu0);
- Header ->
- {ok, NewAccu} = Fun(Header, File, Opts, Accu0),
- foldl_read1(Fun, NewAccu, File, Opts)
+%% Converts the tar header to a record.
+to_v7(Bin) when is_binary(Bin), byte_size(Bin) =:= ?BLOCK_SIZE ->
+ #header_v7{
+ name=binary_part(Bin, ?V7_NAME, ?V7_NAME_LEN),
+ mode=binary_part(Bin, ?V7_MODE, ?V7_MODE_LEN),
+ uid=binary_part(Bin, ?V7_UID, ?V7_UID_LEN),
+ gid=binary_part(Bin, ?V7_GID, ?V7_GID_LEN),
+ size=binary_part(Bin, ?V7_SIZE, ?V7_SIZE_LEN),
+ mtime=binary_part(Bin, ?V7_MTIME, ?V7_MTIME_LEN),
+ checksum=binary_part(Bin, ?V7_CHKSUM, ?V7_CHKSUM_LEN),
+ typeflag=binary:at(Bin, ?V7_TYPE),
+ linkname=binary_part(Bin, ?V7_LINKNAME, ?V7_LINKNAME_LEN)
+ };
+to_v7(_) ->
+ {error, header_block_too_small}.
+
+to_gnu(#header_v7{}=V7, Bin)
+ when is_binary(Bin), byte_size(Bin) =:= ?BLOCK_SIZE ->
+ #header_gnu{
+ header_v7=V7,
+ magic=binary_part(Bin, ?GNU_MAGIC, ?GNU_MAGIC_LEN),
+ version=binary_part(Bin, ?GNU_VERSION, ?GNU_VERSION_LEN),
+ uname=binary_part(Bin, 265, 32),
+ gname=binary_part(Bin, 297, 32),
+ devmajor=binary_part(Bin, 329, 8),
+ devminor=binary_part(Bin, 337, 8),
+ atime=binary_part(Bin, 345, 12),
+ ctime=binary_part(Bin, 357, 12),
+ sparse=to_sparse_array(binary_part(Bin, 386, 24*4+1)),
+ real_size=binary_part(Bin, 483, 12)
+ }.
+
+to_star(#header_v7{}=V7, Bin)
+ when is_binary(Bin), byte_size(Bin) =:= ?BLOCK_SIZE ->
+ #header_star{
+ header_v7=V7,
+ magic=binary_part(Bin, ?USTAR_MAGIC, ?USTAR_MAGIC_LEN),
+ version=binary_part(Bin, ?USTAR_VERSION, ?USTAR_VERSION_LEN),
+ uname=binary_part(Bin, ?USTAR_UNAME, ?USTAR_UNAME_LEN),
+ gname=binary_part(Bin, ?USTAR_GNAME, ?USTAR_GNAME_LEN),
+ devmajor=binary_part(Bin, ?USTAR_DEVMAJ, ?USTAR_DEVMAJ_LEN),
+ devminor=binary_part(Bin, ?USTAR_DEVMIN, ?USTAR_DEVMIN_LEN),
+ prefix=binary_part(Bin, 345, 131),
+ atime=binary_part(Bin, 476, 12),
+ ctime=binary_part(Bin, 488, 12),
+ trailer=binary_part(Bin, ?STAR_TRAILER, ?STAR_TRAILER_LEN)
+ }.
+
+to_ustar(#header_v7{}=V7, Bin)
+ when is_binary(Bin), byte_size(Bin) =:= ?BLOCK_SIZE ->
+ #header_ustar{
+ header_v7=V7,
+ magic=binary_part(Bin, ?USTAR_MAGIC, ?USTAR_MAGIC_LEN),
+ version=binary_part(Bin, ?USTAR_VERSION, ?USTAR_VERSION_LEN),
+ uname=binary_part(Bin, ?USTAR_UNAME, ?USTAR_UNAME_LEN),
+ gname=binary_part(Bin, ?USTAR_GNAME, ?USTAR_GNAME_LEN),
+ devmajor=binary_part(Bin, ?USTAR_DEVMAJ, ?USTAR_DEVMAJ_LEN),
+ devminor=binary_part(Bin, ?USTAR_DEVMIN, ?USTAR_DEVMIN_LEN),
+ prefix=binary_part(Bin, 345, 155)
+ }.
+
+to_sparse_array(Bin) when is_binary(Bin) ->
+ MaxEntries = byte_size(Bin) div 24,
+ IsExtended = 1 =:= binary:at(Bin, 24*MaxEntries),
+ Entries = parse_sparse_entries(Bin, MaxEntries-1, []),
+ #sparse_array{
+ entries=Entries,
+ max_entries=MaxEntries,
+ is_extended=IsExtended
+ }.
+
+parse_sparse_entries(<<>>, _, Acc) ->
+ Acc;
+parse_sparse_entries(_, -1, Acc) ->
+ Acc;
+parse_sparse_entries(Bin, N, Acc) ->
+ case to_sparse_entry(binary_part(Bin, N*24, 24)) of
+ nil ->
+ parse_sparse_entries(Bin, N-1, Acc);
+ Entry = #sparse_entry{} ->
+ parse_sparse_entries(Bin, N-1, [Entry|Acc])
end.
-table1(eof, _, _, Result) ->
- {ok, lists:reverse(Result)};
-table1(Header = #tar_header{}, File, #read_opts{verbose=true}, Result) ->
- #tar_header{name=Name, size=Size, mtime=Mtime, typeflag=Type,
- mode=Mode, uid=Uid, gid=Gid} = Header,
- skip(File, Size),
- {ok, [{Name, Type, Size, posix_to_erlang_time(Mtime), Mode, Uid, Gid}|Result]};
-table1(#tar_header{name=Name, size=Size}, File, _, Result) ->
- skip(File, Size),
- {ok, [Name|Result]}.
-
-extract1(eof, _, _, Acc) ->
- if
- is_list(Acc) ->
- {ok, lists:reverse(Acc)};
- true ->
- Acc
- end;
-extract1(Header, File, Opts, Acc) ->
- Name = Header#tar_header.name,
- case check_extract(Name, Opts) of
- true ->
- {ok, Bin} = get_element(File, Header),
- case write_extracted_element(Header, Bin, Opts) of
- ok ->
- {ok, Acc};
- {ok, NameBin} when is_list(Acc) ->
- {ok, [NameBin | Acc]};
- {ok, NameBin} when Acc =:= ok ->
- {ok, [NameBin]}
- end;
- false ->
- ok = skip(File, Header#tar_header.size),
- {ok, Acc}
+-define(EMPTY_ENTRY, <<0,0,0,0,0,0,0,0,0,0,0,0>>).
+to_sparse_entry(Bin) when is_binary(Bin), byte_size(Bin) =:= 24 ->
+ OffsetBin = binary_part(Bin, 0, 12),
+ NumBytesBin = binary_part(Bin, 12, 12),
+ case {OffsetBin, NumBytesBin} of
+ {?EMPTY_ENTRY, ?EMPTY_ENTRY} ->
+ nil;
+ _ ->
+ #sparse_entry{
+ offset=parse_numeric(OffsetBin),
+ num_bytes=parse_numeric(NumBytesBin)}
end.
-%% Checks if the file Name should be extracted.
+-spec get_format(binary()) -> {ok, pos_integer(), header_v7()}
+ | ?FORMAT_UNKNOWN
+ | {error, term()}.
+get_format(Bin) when is_binary(Bin), byte_size(Bin) =:= ?BLOCK_SIZE ->
+ do_get_format(to_v7(Bin), Bin).
+
+do_get_format({error, _} = Err, _Bin) ->
+ Err;
+do_get_format(#header_v7{}=V7, Bin)
+ when is_binary(Bin), byte_size(Bin) =:= ?BLOCK_SIZE ->
+ Checksum = parse_octal(V7#header_v7.checksum),
+ Chk1 = compute_checksum(Bin),
+ Chk2 = compute_signed_checksum(Bin),
+ if Checksum =/= Chk1 andalso Checksum =/= Chk2 ->
+ ?FORMAT_UNKNOWN;
+ true ->
+ %% guess magic
+ Ustar = to_ustar(V7, Bin),
+ Star = to_star(V7, Bin),
+ Magic = Ustar#header_ustar.magic,
+ Version = Ustar#header_ustar.version,
+ Trailer = Star#header_star.trailer,
+ Format = if
+ Magic =:= ?MAGIC_USTAR, Trailer =:= ?TRAILER_STAR ->
+ ?FORMAT_STAR;
+ Magic =:= ?MAGIC_USTAR ->
+ ?FORMAT_USTAR;
+ Magic =:= ?MAGIC_GNU, Version =:= ?VERSION_GNU ->
+ ?FORMAT_GNU;
+ true ->
+ ?FORMAT_V7
+ end,
+ {ok, Format, V7}
+ end.
-check_extract(_, #read_opts{files=all}) ->
+unpack_format(Format, #header_v7{}=V7, Bin, Reader)
+ when is_binary(Bin), byte_size(Bin) =:= ?BLOCK_SIZE ->
+ Mtime = parse_numeric(V7#header_v7.mtime),
+ Header0 = #tar_header{
+ name=parse_string(V7#header_v7.name),
+ mode=parse_numeric(V7#header_v7.mode),
+ uid=parse_numeric(V7#header_v7.uid),
+ gid=parse_numeric(V7#header_v7.gid),
+ size=parse_numeric(V7#header_v7.size),
+ mtime=Mtime,
+ atime=Mtime,
+ ctime=Mtime,
+ typeflag=V7#header_v7.typeflag,
+ linkname=parse_string(V7#header_v7.linkname)
+ },
+ Typeflag = Header0#tar_header.typeflag,
+ Header1 = if Format > ?FORMAT_V7 ->
+ unpack_modern(Format, V7, Bin, Header0);
+ true ->
+ Name = Header0#tar_header.name,
+ Header0#tar_header{name=safe_join_path("", Name)}
+ end,
+ HeaderOnly = is_header_only_type(Typeflag),
+ Header2 = if HeaderOnly ->
+ Header1#tar_header{size=0};
+ true ->
+ Header1
+ end,
+ if Typeflag =:= ?TYPE_GNU_SPARSE ->
+ Gnu = to_gnu(V7, Bin),
+ RealSize = parse_numeric(Gnu#header_gnu.real_size),
+ {Sparsemap, Reader2} = parse_sparse_map(Gnu, Reader),
+ Header3 = Header2#tar_header{size=RealSize},
+ {Header3, new_sparse_file_reader(Reader2, Sparsemap, RealSize)};
+ true ->
+ FileReader = #reg_file_reader{
+ handle=Reader,
+ num_bytes=Header2#tar_header.size,
+ size=Header2#tar_header.size,
+ pos = 0
+ },
+ {Header2, FileReader}
+ end.
+
+unpack_modern(Format, #header_v7{}=V7, Bin, #tar_header{}=Header0)
+ when is_binary(Bin) ->
+ Typeflag = Header0#tar_header.typeflag,
+ Ustar = to_ustar(V7, Bin),
+ H0 = Header0#tar_header{
+ uname=parse_string(Ustar#header_ustar.uname),
+ gname=parse_string(Ustar#header_ustar.gname)},
+ H1 = if Typeflag =:= ?TYPE_CHAR
+ orelse Typeflag =:= ?TYPE_BLOCK ->
+ Ma = parse_numeric(Ustar#header_ustar.devmajor),
+ Mi = parse_numeric(Ustar#header_ustar.devminor),
+ H0#tar_header{
+ devmajor=Ma,
+ devminor=Mi
+ };
+ true ->
+ H0
+ end,
+ {Prefix, H2} = case Format of
+ ?FORMAT_USTAR ->
+ {parse_string(Ustar#header_ustar.prefix), H1};
+ ?FORMAT_STAR ->
+ Star = to_star(V7, Bin),
+ Prefix0 = parse_string(Star#header_star.prefix),
+ Atime0 = Star#header_star.atime,
+ Atime = parse_numeric(Atime0),
+ Ctime0 = Star#header_star.ctime,
+ Ctime = parse_numeric(Ctime0),
+ {Prefix0, H1#tar_header{
+ atime=Atime,
+ ctime=Ctime
+ }};
+ _ ->
+ {"", H1}
+ end,
+ Name = H2#tar_header.name,
+ H2#tar_header{name=safe_join_path(Prefix, Name)}.
+
+
+safe_join_path([], Name) ->
+ filename:join([Name]);
+safe_join_path(Prefix, []) ->
+ filename:join([Prefix]);
+safe_join_path(Prefix, Name) ->
+ filename:join(Prefix, Name).
+
+new_sparse_file_reader(Reader, Sparsemap, RealSize) ->
+ true = validate_sparse_entries(Sparsemap, RealSize),
+ #sparse_file_reader{
+ handle = Reader,
+ num_bytes = RealSize,
+ pos = 0,
+ size = RealSize,
+ sparse_map = Sparsemap}.
+
+validate_sparse_entries(Entries, RealSize) ->
+ validate_sparse_entries(Entries, RealSize, 0, 0).
+validate_sparse_entries([], _RealSize, _I, _LastOffset) ->
true;
-check_extract(Name, #read_opts{files=Files}) ->
- ordsets:is_element(Name, Files).
+validate_sparse_entries([#sparse_entry{}=Entry|Rest], RealSize, I, LastOffset) ->
+ Offset = Entry#sparse_entry.offset,
+ NumBytes = Entry#sparse_entry.num_bytes,
+ if
+ Offset > ?MAX_INT64-NumBytes ->
+ throw({error, {invalid_sparse_map_entry, offset_too_large}});
+ Offset+NumBytes > RealSize ->
+ throw({error, {invalid_sparse_map_entry, offset_too_large}});
+ I > 0 andalso LastOffset > Offset ->
+ throw({error, {invalid_sparse_map_entry, overlapping_offsets}});
+ true ->
+ ok
+ end,
+ validate_sparse_entries(Rest, RealSize, I+1, Offset+NumBytes).
+
+
+-spec parse_sparse_map(header_gnu(), reader_type()) ->
+ {[sparse_entry()], reader_type()}.
+parse_sparse_map(#header_gnu{sparse=Sparse}, Reader)
+ when Sparse#sparse_array.is_extended ->
+ parse_sparse_map(Sparse, Reader, []);
+parse_sparse_map(#header_gnu{sparse=Sparse}, Reader) ->
+ {Sparse#sparse_array.entries, Reader}.
+parse_sparse_map(#sparse_array{is_extended=true,entries=Entries}, Reader, Acc) ->
+ case read_block(Reader) of
+ eof ->
+ throw({error, eof});
+ {ok, Block, Reader2} ->
+ Sparse2 = to_sparse_array(Block),
+ parse_sparse_map(Sparse2, Reader2, Entries++Acc)
+ end;
+parse_sparse_map(#sparse_array{entries=Entries}, Reader, Acc) ->
+ Sorted = lists:sort(fun (#sparse_entry{offset=A},#sparse_entry{offset=B}) ->
+ A =< B
+ end, Entries++Acc),
+ {Sorted, Reader}.
+
+%% Defined by taking the sum of the unsigned byte values of the
+%% entire header record, treating the checksum bytes to as ASCII spaces
+compute_checksum(<<H1:?V7_CHKSUM/binary,
+ H2:?V7_CHKSUM_LEN/binary,
+ Rest:(?BLOCK_SIZE - ?V7_CHKSUM - ?V7_CHKSUM_LEN)/binary,
+ _/binary>>) ->
+ C0 = checksum(H1) + (byte_size(H2) * $\s),
+ C1 = checksum(Rest),
+ C0 + C1.
+
+compute_signed_checksum(<<H1:?V7_CHKSUM/binary,
+ H2:?V7_CHKSUM_LEN/binary,
+ Rest:(?BLOCK_SIZE - ?V7_CHKSUM - ?V7_CHKSUM_LEN)/binary,
+ _/binary>>) ->
+ C0 = signed_checksum(H1) + (byte_size(H2) * $\s),
+ C1 = signed_checksum(Rest),
+ C0 + C1.
-get_header(File) ->
- case do_read(File, ?record_size) of
- eof ->
- throw({error,eof});
- {ok, Bin} when is_binary(Bin) ->
- convert_header(Bin);
- {ok, List} ->
- convert_header(list_to_binary(List));
- {error, Reason} ->
- throw({error, Reason})
- end.
+%% Returns the checksum of a binary.
+checksum(Bin) -> checksum(Bin, 0).
+checksum(<<A/unsigned,Rest/binary>>, Sum) ->
+ checksum(Rest, Sum+A);
+checksum(<<>>, Sum) -> Sum.
-%% Converts the tar header to a record.
+signed_checksum(Bin) -> signed_checksum(Bin, 0).
+signed_checksum(<<A/signed,Rest/binary>>, Sum) ->
+ signed_checksum(Rest, Sum+A);
+signed_checksum(<<>>, Sum) -> Sum.
+
+-spec parse_numeric(binary()) -> non_neg_integer().
+parse_numeric(<<>>) ->
+ 0;
+parse_numeric(<<First, _/binary>> = Bin) ->
+ %% check for base-256 format first
+ %% if the bit is set, then all following bits constitute a two's
+ %% complement encoded number in big-endian byte order
+ if
+ First band 16#80 =/= 0 ->
+ %% Handling negative numbers relies on the following identity:
+ %% -a-1 == ^a
+ %% If the number is negative, we use an inversion mask to invert
+ %% the data bytes and treat the value as an unsigned number
+ Inv = if First band 16#40 =/= 0 -> 16#00; true -> 16#FF end,
+ Bytes = binary:bin_to_list(Bin),
+ Reducer = fun (C, {I, X}) ->
+ C1 = C bxor Inv,
+ C2 = if I =:= 0 -> C1 band 16#7F; true -> C1 end,
+ if (X bsr 56) > 0 ->
+ throw({error,integer_overflow});
+ true ->
+ {I+1, (X bsl 8) bor C2}
+ end
+ end,
+ {_, N} = lists:foldl(Reducer, {0,0}, Bytes),
+ if (N bsr 63) > 0 ->
+ throw({error, integer_overflow});
+ true ->
+ if Inv =:= 16#FF ->
+ -1 bxor N;
+ true ->
+ N
+ end
+ end;
+ true ->
+ %% normal case is an octal number
+ parse_octal(Bin)
+ end.
-convert_header(Bin) when byte_size(Bin) =:= ?record_size ->
- case verify_checksum(Bin) of
- ok ->
- Hd = #tar_header{name=get_name(Bin),
- mode=from_octal(Bin, ?th_mode, ?th_mode_len),
- uid=from_octal(Bin, ?th_uid, ?th_uid_len),
- gid=from_octal(Bin, ?th_gid, ?th_gid_len),
- size=from_octal(Bin, ?th_size, ?th_size_len),
- mtime=from_octal(Bin, ?th_mtime, ?th_mtime_len),
- linkname=from_string(Bin,
- ?th_linkname, ?th_linkname_len),
- typeflag=typeflag(Bin)},
- convert_header1(Hd);
- eof ->
- eof
+parse_octal(Bin) when is_binary(Bin) ->
+ %% skip leading/trailing zero bytes and spaces
+ do_parse_octal(Bin, <<>>).
+do_parse_octal(<<>>, <<>>) ->
+ 0;
+do_parse_octal(<<>>, Acc) ->
+ case io_lib:fread("~8u", binary:bin_to_list(Acc)) of
+ {error, _} -> throw({error, invalid_tar_checksum});
+ {ok, [Octal], []} -> Octal;
+ {ok, _, _} -> throw({error, invalid_tar_checksum})
+ end;
+do_parse_octal(<<$\s,Rest/binary>>, Acc) ->
+ do_parse_octal(Rest, Acc);
+do_parse_octal(<<0, Rest/binary>>, Acc) ->
+ do_parse_octal(Rest, Acc);
+do_parse_octal(<<C, Rest/binary>>, Acc) ->
+ do_parse_octal(Rest, <<Acc/binary, C>>).
+
+parse_string(Bin) when is_binary(Bin) ->
+ do_parse_string(Bin, <<>>).
+do_parse_string(<<>>, Acc) ->
+ case unicode:characters_to_list(Acc) of
+ Str when is_list(Str) ->
+ Str;
+ {incomplete, _Str, _Rest} ->
+ binary:bin_to_list(Acc);
+ {error, _Str, _Rest} ->
+ throw({error, {bad_header, invalid_string}})
end;
-convert_header(Bin) when byte_size(Bin) =:= 0 ->
+do_parse_string(<<0, _/binary>>, Acc) ->
+ do_parse_string(<<>>, Acc);
+do_parse_string(<<C, Rest/binary>>, Acc) ->
+ do_parse_string(Rest, <<Acc/binary, C>>).
+
+convert_header(Bin, #reader{pos=Pos}=Reader)
+ when byte_size(Bin) =:= ?BLOCK_SIZE, (Pos rem ?BLOCK_SIZE) =:= 0 ->
+ case get_format(Bin) of
+ ?FORMAT_UNKNOWN ->
+ throw({error, bad_header});
+ {ok, Format, V7} ->
+ unpack_format(Format, V7, Bin, Reader);
+ {error, Reason} ->
+ throw({error, {bad_header, Reason}})
+ end;
+convert_header(Bin, #reader{pos=Pos}) when byte_size(Bin) =:= ?BLOCK_SIZE ->
+ throw({error, misaligned_read, Pos});
+convert_header(Bin, _Reader) when byte_size(Bin) =:= 0 ->
eof;
-convert_header(_Bin) ->
+convert_header(_Bin, _Reader) ->
throw({error, eof}).
-%% Basic sanity. Better set the element size to zero here if the type
-%% always is of zero length.
-
-convert_header1(H) when H#tar_header.typeflag =:= symlink, H#tar_header.size =/= 0 ->
- convert_header1(H#tar_header{size=0});
-convert_header1(H) when H#tar_header.typeflag =:= directory, H#tar_header.size =/= 0 ->
- convert_header1(H#tar_header{size=0});
-convert_header1(Header) ->
- Header.
-
-typeflag(Bin) ->
- [T] = binary_to_list(Bin, ?th_typeflag+1, ?th_typeflag+1),
- case T of
- 0 -> regular;
- $0 -> regular;
- $1 -> link;
- $2 -> symlink;
- $3 -> char;
- $4 -> block;
- $5 -> directory;
- $6 -> fifo;
- $7 -> regular;
- _ -> unknown
+%% Creates a partially-populated header record based
+%% on the provided file_info record. If the file is
+%% a symlink, then `link` is used as the link target.
+%% If the file is a directory, a slash is appended to the name.
+fileinfo_to_header(Name, #file_info{}=Fi, Link) when is_list(Name) ->
+ BaseHeader = #tar_header{name=Name,
+ mtime=Fi#file_info.mtime,
+ atime=Fi#file_info.atime,
+ ctime=Fi#file_info.ctime,
+ mode=Fi#file_info.mode,
+ uid=Fi#file_info.uid,
+ gid=Fi#file_info.gid,
+ typeflag=?TYPE_REGULAR},
+ do_fileinfo_to_header(BaseHeader, Fi, Link).
+
+do_fileinfo_to_header(Header, #file_info{size=Size,type=regular}, _Link) ->
+ Header#tar_header{size=Size,typeflag=?TYPE_REGULAR};
+do_fileinfo_to_header(#tar_header{name=Name}=Header,
+ #file_info{type=directory}, _Link) ->
+ Header#tar_header{name=Name++"/",typeflag=?TYPE_DIR};
+do_fileinfo_to_header(Header, #file_info{type=symlink}, Link) ->
+ Header#tar_header{typeflag=?TYPE_SYMLINK,linkname=Link};
+do_fileinfo_to_header(Header, #file_info{type=device,mode=Mode}=Fi, _Link)
+ when (Mode band ?S_IFMT) =:= ?S_IFCHR ->
+ Header#tar_header{typeflag=?TYPE_CHAR,
+ devmajor=Fi#file_info.major_device,
+ devminor=Fi#file_info.minor_device};
+do_fileinfo_to_header(Header, #file_info{type=device,mode=Mode}=Fi, _Link)
+ when (Mode band ?S_IFMT) =:= ?S_IFBLK ->
+ Header#tar_header{typeflag=?TYPE_BLOCK,
+ devmajor=Fi#file_info.major_device,
+ devminor=Fi#file_info.minor_device};
+do_fileinfo_to_header(Header, #file_info{type=other,mode=Mode}, _Link)
+ when (Mode band ?S_IFMT) =:= ?S_FIFO ->
+ Header#tar_header{typeflag=?TYPE_FIFO};
+do_fileinfo_to_header(Header, Fi, _Link) ->
+ {error, {invalid_file_type, Header#tar_header.name, Fi}}.
+
+is_ascii(Str) when is_list(Str) ->
+ not lists:any(fun (Char) -> Char >= 16#80 end, Str);
+is_ascii(Bin) when is_binary(Bin) ->
+ is_ascii1(Bin).
+
+is_ascii1(<<>>) ->
+ true;
+is_ascii1(<<C,_Rest/binary>>) when C >= 16#80 ->
+ false;
+is_ascii1(<<_, Rest/binary>>) ->
+ is_ascii1(Rest).
+
+to_ascii(Str) when is_list(Str) ->
+ case is_ascii(Str) of
+ true ->
+ unicode:characters_to_binary(Str);
+ false ->
+ Chars = lists:filter(fun (Char) -> Char < 16#80 end, Str),
+ unicode:characters_to_binary(Chars)
+ end;
+to_ascii(Bin) when is_binary(Bin) ->
+ to_ascii(Bin, <<>>).
+to_ascii(<<>>, Acc) ->
+ Acc;
+to_ascii(<<C, Rest/binary>>, Acc) when C < 16#80 ->
+ to_ascii(Rest, <<Acc/binary,C>>);
+to_ascii(<<_, Rest/binary>>, Acc) ->
+ to_ascii(Rest, Acc).
+
+is_header_only_type(?TYPE_SYMLINK) -> true;
+is_header_only_type(?TYPE_LINK) -> true;
+is_header_only_type(?TYPE_DIR) -> true;
+is_header_only_type(_) -> false.
+
+foldl_read(#reader{access=read}=Reader, Fun, Accu, #read_opts{}=Opts)
+ when is_function(Fun,4) ->
+ case foldl_read0(Reader, Fun, Accu, Opts) of
+ {ok, Result, _Reader2} ->
+ Result;
+ {error, _} = Err ->
+ Err
+ end;
+foldl_read(#reader{access=Access}, _Fun, _Accu, _Opts) ->
+ {error, {read_mode_expected, Access}};
+foldl_read(TarName, Fun, Accu, #read_opts{}=Opts)
+ when is_function(Fun,4) ->
+ try open(TarName, [read|Opts#read_opts.open_mode]) of
+ {ok, #reader{access=read}=Reader} ->
+ try
+ foldl_read(Reader, Fun, Accu, Opts)
+ after
+ _ = close(Reader)
+ end;
+ {error, _} = Err ->
+ Err
+ catch
+ throw:Err ->
+ Err
end.
-%% Get the name of the file from the prefix and name fields of the
-%% tar header.
-
-get_name(Bin0) ->
- List0 = get_name_raw(Bin0),
- case file:native_name_encoding() of
- utf8 ->
- Bin = list_to_binary(List0),
- case unicode:characters_to_list(Bin) of
- {error,_,_} ->
- List0;
- List when is_list(List) ->
- List
- end;
- latin1 ->
- List0
+foldl_read0(Reader, Fun, Accu, Opts) ->
+ try foldl_read1(Fun, Accu, Reader, Opts, #{}) of
+ {ok,_,_} = Ok ->
+ Ok
+ catch
+ throw:{error, {Reason, Format, Args}} ->
+ read_verbose(Opts, Format, Args),
+ {error, Reason};
+ throw:Err ->
+ Err
end.
-get_name_raw(Bin) ->
- Name = from_string(Bin, ?th_name, ?th_name_len),
- case binary_to_list(Bin, ?th_prefix+1, ?th_prefix+1) of
- [0] ->
- Name;
- [_] ->
- Prefix = binary_to_list(Bin, ?th_prefix+1, byte_size(Bin)),
- lists:reverse(remove_nulls(Prefix), [$/|Name])
+foldl_read1(Fun, Accu0, Reader0, Opts, ExtraHeaders) ->
+ {ok, Reader1} = skip_unread(Reader0),
+ case get_header(Reader1) of
+ eof ->
+ Fun(eof, Reader1, Opts, Accu0);
+ {Header, Reader2} ->
+ case Header#tar_header.typeflag of
+ ?TYPE_X_HEADER ->
+ {ExtraHeaders2, Reader3} = parse_pax(Reader2),
+ ExtraHeaders3 = maps:merge(ExtraHeaders, ExtraHeaders2),
+ foldl_read1(Fun, Accu0, Reader3, Opts, ExtraHeaders3);
+ ?TYPE_GNU_LONGNAME ->
+ {RealName, Reader3} = get_real_name(Reader2),
+ ExtraHeaders2 = maps:put(?PAX_PATH,
+ parse_string(RealName), ExtraHeaders),
+ foldl_read1(Fun, Accu0, Reader3, Opts, ExtraHeaders2);
+ ?TYPE_GNU_LONGLINK ->
+ {RealName, Reader3} = get_real_name(Reader2),
+ ExtraHeaders2 = maps:put(?PAX_LINKPATH,
+ parse_string(RealName), ExtraHeaders),
+ foldl_read1(Fun, Accu0, Reader3, Opts, ExtraHeaders2);
+ _ ->
+ Header1 = merge_pax(Header, ExtraHeaders),
+ {ok, NewAccu, Reader3} = Fun(Header1, Reader2, Opts, Accu0),
+ foldl_read1(Fun, NewAccu, Reader3, Opts, #{})
+ end
end.
-from_string(Bin, Pos, Len) ->
- lists:reverse(remove_nulls(binary_to_list(Bin, Pos+1, Pos+Len))).
-
-%% Returns all characters up to (but not including) the first null
-%% character, in REVERSE order.
-
-remove_nulls(List) ->
- remove_nulls(List, []).
-
-remove_nulls([0|_], Result) ->
- remove_nulls([], Result);
-remove_nulls([C|Rest], Result) ->
- remove_nulls(Rest, [C|Result]);
-remove_nulls([], Result) ->
- Result.
-
-from_octal(Bin, Pos, Len) ->
- from_octal(binary_to_list(Bin, Pos+1, Pos+Len)).
-
-from_octal([$\s|Rest]) ->
- from_octal(Rest);
-from_octal([Digit|Rest]) when $0 =< Digit, Digit =< $7 ->
- from_octal(Rest, Digit-$0);
-from_octal(Bin) when is_binary(Bin) ->
- from_octal(binary_to_list(Bin));
-from_octal(Other) ->
- throw({error, {bad_header, "Bad octal number: ~p", [Other]}}).
-
-from_octal([Digit|Rest], Result) when $0 =< Digit, Digit =< $7 ->
- from_octal(Rest, Result*8+Digit-$0);
-from_octal([$\s|_], Result) ->
- Result;
-from_octal([0|_], Result) ->
- Result;
-from_octal(Other, _) ->
- throw({error, {bad_header, "Bad contents in octal field: ~p", [Other]}}).
-
-%% Retrieves the next element from the archive.
-%% Returns {ok, Bin} | eof | {error, Reason}
-
-get_element(File, #tar_header{size = 0}) ->
- skip_to_next(File),
- {ok,<<>>};
-get_element(File, #tar_header{size = Size}) ->
- case do_read(File, Size) of
- {ok,Bin}=Res when byte_size(Bin) =:= Size ->
- skip_to_next(File),
- Res;
- {ok,List} when length(List) =:= Size ->
- skip_to_next(File),
- {ok,list_to_binary(List)};
- {ok,_} -> throw({error,eof});
- {error, Reason} -> throw({error, Reason});
- eof -> throw({error,eof})
+%% Applies all known PAX attributes to the current tar header
+-spec merge_pax(tar_header(), #{binary() => binary()}) -> tar_header().
+merge_pax(Header, ExtraHeaders) when is_map(ExtraHeaders) ->
+ do_merge_pax(Header, maps:to_list(ExtraHeaders)).
+
+do_merge_pax(Header, []) ->
+ Header;
+do_merge_pax(Header, [{?PAX_PATH, Path}|Rest]) ->
+ do_merge_pax(Header#tar_header{name=unicode:characters_to_list(Path)}, Rest);
+do_merge_pax(Header, [{?PAX_LINKPATH, LinkPath}|Rest]) ->
+ do_merge_pax(Header#tar_header{linkname=unicode:characters_to_list(LinkPath)}, Rest);
+do_merge_pax(Header, [{?PAX_GNAME, Gname}|Rest]) ->
+ do_merge_pax(Header#tar_header{gname=unicode:characters_to_list(Gname)}, Rest);
+do_merge_pax(Header, [{?PAX_UNAME, Uname}|Rest]) ->
+ do_merge_pax(Header#tar_header{uname=unicode:characters_to_list(Uname)}, Rest);
+do_merge_pax(Header, [{?PAX_UID, Uid}|Rest]) ->
+ Uid2 = binary_to_integer(Uid),
+ do_merge_pax(Header#tar_header{uid=Uid2}, Rest);
+do_merge_pax(Header, [{?PAX_GID, Gid}|Rest]) ->
+ Gid2 = binary_to_integer(Gid),
+ do_merge_pax(Header#tar_header{gid=Gid2}, Rest);
+do_merge_pax(Header, [{?PAX_ATIME, Atime}|Rest]) ->
+ Atime2 = parse_pax_time(Atime),
+ do_merge_pax(Header#tar_header{atime=Atime2}, Rest);
+do_merge_pax(Header, [{?PAX_MTIME, Mtime}|Rest]) ->
+ Mtime2 = parse_pax_time(Mtime),
+ do_merge_pax(Header#tar_header{mtime=Mtime2}, Rest);
+do_merge_pax(Header, [{?PAX_CTIME, Ctime}|Rest]) ->
+ Ctime2 = parse_pax_time(Ctime),
+ do_merge_pax(Header#tar_header{ctime=Ctime2}, Rest);
+do_merge_pax(Header, [{?PAX_SIZE, Size}|Rest]) ->
+ Size2 = binary_to_integer(Size),
+ do_merge_pax(Header#tar_header{size=Size2}, Rest);
+do_merge_pax(Header, [{<<?PAX_XATTR_STR, _Key/binary>>, _Value}|Rest]) ->
+ do_merge_pax(Header, Rest);
+do_merge_pax(Header, [_Ignore|Rest]) ->
+ do_merge_pax(Header, Rest).
+
+%% Returns the time since UNIX epoch as a datetime
+-spec parse_pax_time(binary()) -> tar_time().
+parse_pax_time(Bin) when is_binary(Bin) ->
+ TotalNano = case binary:split(Bin, [<<$.>>]) of
+ [SecondsStr, NanoStr0] ->
+ Seconds = binary_to_integer(SecondsStr),
+ if byte_size(NanoStr0) < ?MAX_NANO_INT_SIZE ->
+ %% right pad
+ PaddingN = ?MAX_NANO_INT_SIZE-byte_size(NanoStr0),
+ Padding = binary:copy(<<$0>>, PaddingN),
+ NanoStr1 = <<NanoStr0/binary,Padding/binary>>,
+ Nano = binary_to_integer(NanoStr1),
+ (Seconds*?BILLION)+Nano;
+ byte_size(NanoStr0) > ?MAX_NANO_INT_SIZE ->
+ %% right truncate
+ NanoStr1 = binary_part(NanoStr0, 0, ?MAX_NANO_INT_SIZE),
+ Nano = binary_to_integer(NanoStr1),
+ (Seconds*?BILLION)+Nano;
+ true ->
+ (Seconds*?BILLION)+binary_to_integer(NanoStr0)
+ end;
+ [SecondsStr] ->
+ binary_to_integer(SecondsStr)*?BILLION
+ end,
+ %% truncate to microseconds
+ Micro = TotalNano div 1000,
+ Mega = Micro div 1000000000000,
+ Secs = Micro div 1000000 - (Mega*1000000),
+ Secs.
+
+%% Given a regular file reader, reads the whole file and
+%% parses all extended attributes it contains.
+parse_pax(#reg_file_reader{handle=Handle,num_bytes=0}) ->
+ {#{}, Handle};
+parse_pax(#reg_file_reader{handle=Handle0,num_bytes=NumBytes}) ->
+ case do_read(Handle0, NumBytes) of
+ {ok, Bytes, Handle1} ->
+ do_parse_pax(Handle1, Bytes, #{});
+ {error, _} = Err ->
+ throw(Err)
end.
-%% Verify the checksum in the header. First try an unsigned addition
-%% of all bytes in the header (as it should be according to Posix).
-
-verify_checksum(Bin) ->
- <<H1:?th_chksum/binary,CheckStr:?th_chksum_len/binary,H2/binary>> = Bin,
- case checksum(H1) + checksum(H2) of
- 0 -> eof;
- Checksum0 ->
- Csum = from_octal(CheckStr),
- CsumInit = ?th_chksum_len * $\s,
- case Checksum0 + CsumInit of
- Csum -> ok;
- Unsigned ->
- verify_checksum(H1, H2, CsumInit, Csum, Unsigned)
- end
+do_parse_pax(Reader, <<>>, Headers) ->
+ {Headers, Reader};
+do_parse_pax(Reader, Bin, Headers) ->
+ {Key, Value, Residual} = parse_pax_record(Bin),
+ NewHeaders = maps:put(Key, Value, Headers),
+ do_parse_pax(Reader, Residual, NewHeaders).
+
+%% Parse an extended attribute
+parse_pax_record(Bin) when is_binary(Bin) ->
+ case binary:split(Bin, [<<$\n>>]) of
+ [Record, Residual] ->
+ case binary:split(Record, [<<$\s>>], [trim_all]) of
+ [_Len, Record1] ->
+ case binary:split(Record1, [<<$=>>], [trim_all]) of
+ [AttrName, AttrValue] ->
+ {AttrName, AttrValue, Residual};
+ _Other ->
+ throw({error, malformed_pax_record})
+ end;
+ _Other ->
+ throw({error, malformed_pax_record})
+ end;
+ _Other ->
+ throw({error, malformed_pax_record})
end.
-%% The checksums didn't match. Now try a signed addition.
+get_real_name(#reg_file_reader{handle=Handle,num_bytes=0}) ->
+ {"", Handle};
+get_real_name(#reg_file_reader{handle=Handle0,num_bytes=NumBytes}) ->
+ case do_read(Handle0, NumBytes) of
+ {ok, RealName, Handle1} ->
+ {RealName, Handle1};
+ {error, _} = Err ->
+ throw(Err)
+ end;
+get_real_name(#sparse_file_reader{num_bytes=NumBytes}=Reader0) ->
+ case do_read(Reader0, NumBytes) of
+ {ok, RealName, Reader1} ->
+ {RealName, Reader1};
+ {error, _} = Err ->
+ throw(Err)
+ end.
-verify_checksum(H1, H2, Csum, ShouldBe, Unsigned) ->
- case signed_sum(binary_to_list(H1), signed_sum(binary_to_list(H2), Csum)) of
- ShouldBe -> ok;
- Signed ->
- throw({error,
- {bad_header,
- "Incorrect directory checksum ~w (~w), should be ~w",
- [Signed, Unsigned, ShouldBe]}})
+%% Skip the remaining bytes for the current file entry
+skip_file(#reg_file_reader{handle=Handle0,pos=Pos,size=Size}=Reader) ->
+ Padding = skip_padding(Size),
+ AbsPos = Handle0#reader.pos + (Size-Pos) + Padding,
+ case do_position(Handle0, AbsPos) of
+ {ok, _, Handle1} ->
+ Reader#reg_file_reader{handle=Handle1,num_bytes=0,pos=Size};
+ Err ->
+ throw(Err)
+ end;
+skip_file(#sparse_file_reader{pos=Pos,size=Size}=Reader) ->
+ case do_read(Reader, Size-Pos) of
+ {ok, _, Reader2} ->
+ Reader2;
+ Err ->
+ throw(Err)
end.
-signed_sum([C|Rest], Sum) when C < 128 ->
- signed_sum(Rest, Sum+C);
-signed_sum([C|Rest], Sum) ->
- signed_sum(Rest, Sum+C-256);
-signed_sum([], Sum) -> Sum.
-
-write_extracted_element(Header, Bin, Opts)
- when Opts#read_opts.output =:= memory ->
- case Header#tar_header.typeflag of
- regular ->
- {ok, {Header#tar_header.name, Bin}};
- _ ->
- ok
+skip_padding(0) ->
+ 0;
+skip_padding(Size) when (Size rem ?BLOCK_SIZE) =:= 0 ->
+ 0;
+skip_padding(Size) when Size =< ?BLOCK_SIZE ->
+ ?BLOCK_SIZE - Size;
+skip_padding(Size) ->
+ ?BLOCK_SIZE - (Size rem ?BLOCK_SIZE).
+
+skip_unread(#reader{pos=Pos}=Reader0) when (Pos rem ?BLOCK_SIZE) > 0 ->
+ Padding = skip_padding(Pos + ?BLOCK_SIZE),
+ AbsPos = Pos + Padding,
+ case do_position(Reader0, AbsPos) of
+ {ok, _, Reader1} ->
+ {ok, Reader1};
+ Err ->
+ throw(Err)
+ end;
+skip_unread(#reader{}=Reader) ->
+ {ok, Reader};
+skip_unread(#reg_file_reader{handle=Handle,num_bytes=0}) ->
+ skip_unread(Handle);
+skip_unread(#reg_file_reader{}=Reader) ->
+ #reg_file_reader{handle=Handle} = skip_file(Reader),
+ {ok, Handle};
+skip_unread(#sparse_file_reader{handle=Handle,num_bytes=0}) ->
+ skip_unread(Handle);
+skip_unread(#sparse_file_reader{}=Reader) ->
+ #sparse_file_reader{handle=Handle} = skip_file(Reader),
+ {ok, Handle}.
+
+write_extracted_element(#tar_header{name=Name,typeflag=Type},
+ Bin,
+ #read_opts{output=memory}=Opts) ->
+ case typeflag(Type) of
+ regular ->
+ read_verbose(Opts, "x ~ts~n", [Name]),
+ {ok, {Name, Bin}};
+ _ ->
+ ok
end;
-write_extracted_element(Header, Bin, Opts) ->
- Name = filename:absname(Header#tar_header.name, Opts#read_opts.cwd),
- Created =
- case Header#tar_header.typeflag of
- regular ->
- write_extracted_file(Name, Bin, Opts);
- directory ->
- create_extracted_dir(Name, Opts);
- symlink ->
- create_symlink(Name, Header, Opts);
- Other -> % Ignore.
- read_verbose(Opts, "x ~ts - unsupported type ~p~n",
- [Name, Other]),
- not_written
- end,
+write_extracted_element(#tar_header{name=Name0}=Header, Bin, Opts) ->
+ Name1 = make_safe_path(Name0, Opts),
+ Created =
+ case typeflag(Header#tar_header.typeflag) of
+ regular ->
+ create_regular(Name1, Name0, Bin, Opts);
+ directory ->
+ read_verbose(Opts, "x ~ts~n", [Name0]),
+ create_extracted_dir(Name1, Opts);
+ symlink ->
+ read_verbose(Opts, "x ~ts~n", [Name0]),
+ create_symlink(Name1, Header#tar_header.linkname, Opts);
+ Device when Device =:= char orelse Device =:= block ->
+ %% char/block devices will be created as empty files
+ %% and then have their major/minor device set later
+ create_regular(Name1, Name0, <<>>, Opts);
+ fifo ->
+ %% fifo devices will be created as empty files
+ create_regular(Name1, Name0, <<>>, Opts);
+ Other -> % Ignore.
+ read_verbose(Opts, "x ~ts - unsupported type ~p~n",
+ [Name0, Other]),
+ not_written
+ end,
case Created of
- ok -> set_extracted_file_info(Name, Header);
- not_written -> ok
+ ok -> set_extracted_file_info(Name1, Header);
+ not_written -> ok
+ end.
+
+make_safe_path([$/|Path], Opts) ->
+ make_safe_path(Path, Opts);
+make_safe_path(Path, #read_opts{cwd=Cwd}) ->
+ case filename:safe_relative_path(Path) of
+ unsafe ->
+ throw({error,{Path,unsafe_path}});
+ SafePath ->
+ filename:absname(SafePath, Cwd)
+ end.
+
+create_regular(Name, NameInArchive, Bin, Opts) ->
+ case write_extracted_file(Name, Bin, Opts) of
+ not_written ->
+ read_verbose(Opts, "x ~ts - exists, not created~n", [NameInArchive]),
+ not_written;
+ Ok ->
+ read_verbose(Opts, "x ~ts~n", [NameInArchive]),
+ Ok
end.
create_extracted_dir(Name, _Opts) ->
case file:make_dir(Name) of
- ok -> ok;
- {error,enotsup} -> not_written;
- {error,eexist} -> not_written;
- {error,enoent} -> make_dirs(Name, dir);
- {error,Reason} -> throw({error, Reason})
+ ok -> ok;
+ {error,enotsup} -> not_written;
+ {error,eexist} -> not_written;
+ {error,enoent} -> make_dirs(Name, dir);
+ {error,Reason} -> throw({error, Reason})
end.
-create_symlink(Name, #tar_header{linkname=Linkname}=Header, Opts) ->
+create_symlink(Name, Linkname, Opts) ->
case file:make_symlink(Linkname, Name) of
- ok -> ok;
- {error,enoent} ->
- ok = make_dirs(Name, file),
- create_symlink(Name, Header, Opts);
- {error,eexist} -> not_written;
- {error,enotsup} ->
- read_verbose(Opts, "x ~ts - symbolic links not supported~n", [Name]),
- not_written;
- {error,Reason} -> throw({error, Reason})
+ ok -> ok;
+ {error,enoent} ->
+ ok = make_dirs(Name, file),
+ create_symlink(Name, Linkname, Opts);
+ {error,eexist} -> not_written;
+ {error,enotsup} ->
+ read_verbose(Opts, "x ~ts - symbolic links not supported~n", [Name]),
+ not_written;
+ {error,Reason} -> throw({error, Reason})
end.
write_extracted_file(Name, Bin, Opts) ->
Write =
- case Opts#read_opts.keep_old_files of
- true ->
- case file:read_file_info(Name) of
- {ok, _} -> false;
- _ -> true
- end;
- false -> true
- end,
+ case Opts#read_opts.keep_old_files of
+ true ->
+ case file:read_file_info(Name) of
+ {ok, _} -> false;
+ _ -> true
+ end;
+ false -> true
+ end,
case Write of
- true ->
- read_verbose(Opts, "x ~ts~n", [Name]),
- write_file(Name, Bin);
- false ->
- read_verbose(Opts, "x ~ts - exists, not created~n", [Name]),
- not_written
+ true -> write_file(Name, Bin);
+ false -> not_written
end.
write_file(Name, Bin) ->
case file:write_file(Name, Bin) of
- ok -> ok;
- {error,enoent} ->
- ok = make_dirs(Name, file),
- write_file(Name, Bin);
- {error,Reason} ->
- throw({error, Reason})
+ ok -> ok;
+ {error,enoent} ->
+ ok = make_dirs(Name, file),
+ write_file(Name, Bin);
+ {error,Reason} ->
+ throw({error, Reason})
end.
-set_extracted_file_info(_, #tar_header{typeflag = symlink}) -> ok;
-set_extracted_file_info(Name, #tar_header{mode=Mode, mtime=Mtime}) ->
- Info = #file_info{mode=Mode, mtime=posix_to_erlang_time(Mtime)},
+set_extracted_file_info(_, #tar_header{typeflag = ?TYPE_SYMLINK}) -> ok;
+set_extracted_file_info(_, #tar_header{typeflag = ?TYPE_LINK}) -> ok;
+set_extracted_file_info(Name, #tar_header{typeflag = ?TYPE_CHAR}=Header) ->
+ set_device_info(Name, Header);
+set_extracted_file_info(Name, #tar_header{typeflag = ?TYPE_BLOCK}=Header) ->
+ set_device_info(Name, Header);
+set_extracted_file_info(Name, #tar_header{mtime=Mtime,mode=Mode}) ->
+ Info = #file_info{mode=Mode, mtime=Mtime},
+ file:write_file_info(Name, Info, [{time, posix}]).
+
+set_device_info(Name, #tar_header{}=Header) ->
+ Mtime = Header#tar_header.mtime,
+ Mode = Header#tar_header.mode,
+ Devmajor = Header#tar_header.devmajor,
+ Devminor = Header#tar_header.devminor,
+ Info = #file_info{
+ mode=Mode,
+ mtime=Mtime,
+ major_device=Devmajor,
+ minor_device=Devminor
+ },
file:write_file_info(Name, Info).
%% Makes all directories leading up to the file.
make_dirs(Name, file) ->
- filelib:ensure_dir(Name);
+ filelib:ensure_dir(Name);
make_dirs(Name, dir) ->
- filelib:ensure_dir(filename:join(Name,"*")).
+ filelib:ensure_dir(filename:join(Name,"*")).
%% Prints the message on if the verbose option is given (for reading).
-
read_verbose(#read_opts{verbose=true}, Format, Args) ->
- io:format(Format, Args),
- io:nl();
+ io:format(Format, Args);
read_verbose(_, _, _) ->
ok.
+%% Prints the message on if the verbose option is given.
+add_verbose(#add_opts{verbose=true}, Format, Args) ->
+ io:format(Format, Args);
+add_verbose(_, _, _) ->
+ ok.
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-%%%
-%%% Utility functions.
-%%%
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-%% Returns the checksum of a binary.
-
-checksum(Bin) -> checksum(Bin, 0).
-
-checksum(<<A,B,C,D,E,F,G,H,T/binary>>, Sum) ->
- checksum(T, Sum+A+B+C+D+E+F+G+H);
-checksum(<<A,T/binary>>, Sum) ->
- checksum(T, Sum+A);
-checksum(<<>>, Sum) -> Sum.
-
-%% Returns a list of zeroes to pad out to the given block size.
-
-padding(Size, BlockSize) ->
- zeroes(pad_size(Size, BlockSize)).
-
-pad_size(Size, BlockSize) ->
- case Size rem BlockSize of
- 0 -> 0;
- Rem -> BlockSize-Rem
+%%%%%%%%%%%%%%%%%%
+%% I/O primitives
+%%%%%%%%%%%%%%%%%%
+
+do_write(#reader{handle=Handle,func=Fun}=Reader0, Data)
+ when is_function(Fun,2) ->
+ case Fun(write,{Handle,Data}) of
+ ok ->
+ {ok, Pos, Reader1} = do_position(Reader0, {cur,0}),
+ {ok, Reader1#reader{pos=Pos}};
+ {error, _} = Err ->
+ Err
end.
-zeroes(0) -> [];
-zeroes(1) -> [0];
-zeroes(2) -> [0,0];
-zeroes(Number) ->
- Half = zeroes(Number div 2),
- case Number rem 2 of
- 0 -> [Half|Half];
- 1 -> [Half|[0|Half]]
+do_copy(#reader{func=Fun}=Reader, Source, #add_opts{chunk_size=0}=Opts)
+ when is_function(Fun, 2) ->
+ do_copy(Reader, Source, Opts#add_opts{chunk_size=65536});
+do_copy(#reader{func=Fun}=Reader, Source, #add_opts{chunk_size=ChunkSize})
+ when is_function(Fun, 2) ->
+ case file:open(Source, [read, binary]) of
+ {ok, SourceFd} ->
+ case copy_chunked(Reader, SourceFd, ChunkSize, 0) of
+ {ok, _Copied, _Reader2} = Ok->
+ _ = file:close(SourceFd),
+ Ok;
+ Err ->
+ _ = file:close(SourceFd),
+ throw(Err)
+ end;
+ Err ->
+ throw(Err)
end.
-%% Skips the given number of bytes rounded up to an even record.
+copy_chunked(#reader{}=Reader, Source, ChunkSize, Copied) ->
+ case file:read(Source, ChunkSize) of
+ {ok, Bin} ->
+ {ok, Reader2} = do_write(Reader, Bin),
+ copy_chunked(Reader2, Source, ChunkSize, Copied+byte_size(Bin));
+ eof ->
+ {ok, Copied, Reader};
+ Other ->
+ Other
+ end.
-skip(File, Size) ->
- %% Note: There is no point in handling failure to get the current position
- %% in the file. If it doesn't work, something serious is wrong.
- Amount = ((Size + ?record_size - 1) div ?record_size) * ?record_size,
- {ok,_} = do_position(File, {cur, Amount}),
- ok.
-%% Skips to the next record in the file.
+do_position(#reader{handle=Handle,func=Fun}=Reader, Pos)
+ when is_function(Fun,2)->
+ case Fun(position, {Handle,Pos}) of
+ {ok, NewPos} ->
+ %% since Pos may not always be an absolute seek,
+ %% make sure we update the reader with the new absolute position
+ {ok, AbsPos} = Fun(position, {Handle, {cur, 0}}),
+ {ok, NewPos, Reader#reader{pos=AbsPos}};
+ Other ->
+ Other
+ end.
-skip_to_next(File) ->
- %% Note: There is no point in handling failure to get the current position
- %% in the file. If it doesn't work, something serious is wrong.
- {ok, Position} = do_position(File, {cur, 0}),
- NewPosition = ((Position + ?record_size - 1) div ?record_size) * ?record_size,
- {ok,NewPosition} = do_position(File, NewPosition),
- ok.
+do_read(#reg_file_reader{handle=Handle,pos=Pos,size=Size}=Reader, Len) ->
+ NumBytes = Size - Pos,
+ ActualLen = if NumBytes - Len < 0 -> NumBytes; true -> Len end,
+ case do_read(Handle, ActualLen) of
+ {ok, Bin, Handle2} ->
+ NewPos = Pos + ActualLen,
+ NumBytes2 = Size - NewPos,
+ Reader1 = Reader#reg_file_reader{
+ handle=Handle2,
+ pos=NewPos,
+ num_bytes=NumBytes2},
+ {ok, Bin, Reader1};
+ Other ->
+ Other
+ end;
+do_read(#sparse_file_reader{}=Reader, Len) ->
+ do_sparse_read(Reader, Len);
+do_read(#reader{pos=Pos,handle=Handle,func=Fun}=Reader, Len)
+ when is_function(Fun,2)->
+ %% Always convert to binary internally
+ case Fun(read2,{Handle,Len}) of
+ {ok, List} when is_list(List) ->
+ Bin = list_to_binary(List),
+ NewPos = Pos+byte_size(Bin),
+ {ok, Bin, Reader#reader{pos=NewPos}};
+ {ok, Bin} when is_binary(Bin) ->
+ NewPos = Pos+byte_size(Bin),
+ {ok, Bin, Reader#reader{pos=NewPos}};
+ Other ->
+ Other
+ end.
-%% Prints the message on if the verbose option is given.
-add_verbose(#add_opts{verbose=true}, Format, Args) ->
- io:format(Format, Args);
-add_verbose(_, _, _) ->
- ok.
-
-%% Converts a tuple containing the time to a Posix time (seconds
-%% since Jan 1, 1970).
-
-posix_time(Time) ->
- EpochStart = {{1970,1,1},{0,0,0}},
- {Days,{Hour,Min,Sec}} = calendar:time_difference(EpochStart, Time),
- 86400*Days + 3600*Hour + 60*Min + Sec.
-
-posix_to_erlang_time(Sec) ->
- OneMillion = 1000000,
- Time = calendar:now_to_datetime({Sec div OneMillion, Sec rem OneMillion, 0}),
- erlang:universaltime_to_localtime(Time).
-
-read_file_and_info(Name, Opts) ->
- ReadInfo = Opts#add_opts.read_info,
- case ReadInfo(Name) of
- {ok,Info} when Info#file_info.type =:= regular,
- Opts#add_opts.chunk_size>0 ->
- {ok,chunked,Info};
- {ok,Info} when Info#file_info.type =:= regular ->
- case file:read_file(Name) of
- {ok,Bin} ->
- {ok,Bin,Info};
- Error ->
- Error
- end;
- {ok,Info} when Info#file_info.type =:= symlink ->
- case file:read_link(Name) of
- {ok,PointsTo} ->
- {ok,PointsTo,Info};
- Error ->
- Error
- end;
- {ok, Info} ->
- {ok,[],Info};
- Error ->
- Error
+do_sparse_read(Reader, Len) ->
+ do_sparse_read(Reader, Len, <<>>).
+
+do_sparse_read(#sparse_file_reader{sparse_map=[#sparse_entry{num_bytes=0}|Entries]
+ }=Reader0, Len, Acc) ->
+ %% skip all empty fragments
+ Reader1 = Reader0#sparse_file_reader{sparse_map=Entries},
+ do_sparse_read(Reader1, Len, Acc);
+do_sparse_read(#sparse_file_reader{sparse_map=[],
+ pos=Pos,size=Size}=Reader0, Len, Acc)
+ when Pos < Size ->
+ %% if there are no more fragments, it is possible that there is one last sparse hole
+ %% this behaviour matches the BSD tar utility
+ %% however, GNU tar stops returning data even if we haven't reached the end
+ {ok, Bin, Reader1} = read_sparse_hole(Reader0, Size, Len),
+ do_sparse_read(Reader1, Len-byte_size(Bin), <<Acc/binary,Bin/binary>>);
+do_sparse_read(#sparse_file_reader{sparse_map=[]}=Reader, _Len, Acc) ->
+ {ok, Acc, Reader};
+do_sparse_read(#sparse_file_reader{}=Reader, 0, Acc) ->
+ {ok, Acc, Reader};
+do_sparse_read(#sparse_file_reader{sparse_map=[#sparse_entry{offset=Offset}|_],
+ pos=Pos}=Reader0, Len, Acc)
+ when Pos < Offset ->
+ {ok, Bin, Reader1} = read_sparse_hole(Reader0, Offset, Offset-Pos),
+ do_sparse_read(Reader1, Len-byte_size(Bin), <<Acc/binary,Bin/binary>>);
+do_sparse_read(#sparse_file_reader{sparse_map=[Entry|Entries],
+ pos=Pos}=Reader0, Len, Acc) ->
+ %% we're in a data fragment, so read from it
+ %% end offset of fragment
+ EndPos = Entry#sparse_entry.offset + Entry#sparse_entry.num_bytes,
+ %% bytes left in fragment
+ NumBytes = EndPos - Pos,
+ ActualLen = if Len > NumBytes -> NumBytes; true -> Len end,
+ case do_read(Reader0#sparse_file_reader.handle, ActualLen) of
+ {ok, Bin, Handle} ->
+ BytesRead = byte_size(Bin),
+ ActualEndPos = Pos+BytesRead,
+ Reader1 = if ActualEndPos =:= EndPos ->
+ Reader0#sparse_file_reader{sparse_map=Entries};
+ true ->
+ Reader0
+ end,
+ Size = Reader1#sparse_file_reader.size,
+ NumBytes2 = Size - ActualEndPos,
+ Reader2 = Reader1#sparse_file_reader{
+ handle=Handle,
+ pos=ActualEndPos,
+ num_bytes=NumBytes2},
+ do_sparse_read(Reader2, Len-byte_size(Bin), <<Acc/binary,Bin/binary>>);
+ Other ->
+ Other
end.
-foreach_while_ok(Fun, [First|Rest]) ->
- case Fun(First) of
- ok -> foreach_while_ok(Fun, Rest);
- Other -> Other
- end;
-foreach_while_ok(_, []) -> ok.
-
-open_mode(Mode) ->
- open_mode(Mode, false, [raw], []).
+%% Reads a sparse hole ending at Offset
+read_sparse_hole(#sparse_file_reader{pos=Pos}=Reader, Offset, Len) ->
+ N = Offset - Pos,
+ N2 = if N > Len ->
+ Len;
+ true ->
+ N
+ end,
+ Bin = <<0:N2/unit:8>>,
+ NumBytes = Reader#sparse_file_reader.size - (Pos+N2),
+ {ok, Bin, Reader#sparse_file_reader{
+ num_bytes=NumBytes,
+ pos=Pos+N2}}.
+
+-spec do_close(reader()) -> ok | {error, term()}.
+do_close(#reader{handle=Handle,func=Fun}) when is_function(Fun,2) ->
+ Fun(close,Handle).
+
+%%%%%%%%%%%%%%%%%%
+%% Option parsing
+%%%%%%%%%%%%%%%%%%
-open_mode(read, _, Raw, _) ->
- {ok, read, Raw, []};
-open_mode(write, _, Raw, _) ->
- {ok, write, Raw, []};
-open_mode([read|Rest], false, Raw, Opts) ->
- open_mode(Rest, read, Raw, Opts);
-open_mode([write|Rest], false, Raw, Opts) ->
- open_mode(Rest, write, Raw, Opts);
-open_mode([compressed|Rest], Access, Raw, Opts) ->
- open_mode(Rest, Access, Raw, [compressed|Opts]);
-open_mode([cooked|Rest], Access, _Raw, Opts) ->
- open_mode(Rest, Access, [], Opts);
-open_mode([], Access, Raw, Opts) ->
- {ok, Access, Raw, Opts};
-open_mode(_, _, _, _) ->
- {error, einval}.
+extract_opts(List) ->
+ extract_opts(List, default_options()).
-%%%================================================================
-do_write({tar_descriptor,UsrHandle,Fun}, Data) -> Fun(write,{UsrHandle,Data}).
+table_opts(List) ->
+ read_opts(List, default_options()).
-do_position({tar_descriptor,UsrHandle,Fun}, Pos) -> Fun(position,{UsrHandle,Pos}).
+default_options() ->
+ {ok, Cwd} = file:get_cwd(),
+ #read_opts{cwd=Cwd}.
-do_read({tar_descriptor,UsrHandle,Fun}, Len) -> Fun(read2,{UsrHandle,Len}).
+extract_opts([keep_old_files|Rest], Opts) ->
+ extract_opts(Rest, Opts#read_opts{keep_old_files=true});
+extract_opts([{cwd, Cwd}|Rest], Opts) ->
+ extract_opts(Rest, Opts#read_opts{cwd=Cwd});
+extract_opts([{files, Files}|Rest], Opts) ->
+ Set = ordsets:from_list(Files),
+ extract_opts(Rest, Opts#read_opts{files=Set});
+extract_opts([memory|Rest], Opts) ->
+ extract_opts(Rest, Opts#read_opts{output=memory});
+extract_opts([compressed|Rest], Opts=#read_opts{open_mode=OpenMode}) ->
+ extract_opts(Rest, Opts#read_opts{open_mode=[compressed|OpenMode]});
+extract_opts([cooked|Rest], Opts=#read_opts{open_mode=OpenMode}) ->
+ extract_opts(Rest, Opts#read_opts{open_mode=[cooked|OpenMode]});
+extract_opts([verbose|Rest], Opts) ->
+ extract_opts(Rest, Opts#read_opts{verbose=true});
+extract_opts([Other|Rest], Opts) ->
+ extract_opts(Rest, read_opts([Other], Opts));
+extract_opts([], Opts) ->
+ Opts.
-do_close({tar_descriptor,UsrHandle,Fun}) -> Fun(close,UsrHandle).
+read_opts([compressed|Rest], Opts=#read_opts{open_mode=OpenMode}) ->
+ read_opts(Rest, Opts#read_opts{open_mode=[compressed|OpenMode]});
+read_opts([cooked|Rest], Opts=#read_opts{open_mode=OpenMode}) ->
+ read_opts(Rest, Opts#read_opts{open_mode=[cooked|OpenMode]});
+read_opts([verbose|Rest], Opts) ->
+ read_opts(Rest, Opts#read_opts{verbose=true});
+read_opts([_|Rest], Opts) ->
+ read_opts(Rest, Opts);
+read_opts([], Opts) ->
+ Opts.
diff --git a/lib/stdlib/src/erl_tar.hrl b/lib/stdlib/src/erl_tar.hrl
new file mode 100644
index 0000000000..cff0c2f500
--- /dev/null
+++ b/lib/stdlib/src/erl_tar.hrl
@@ -0,0 +1,396 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2017. All Rights Reserved.
+%%
+%% Licensed under the Apache License, Version 2.0 (the "License");
+%% you may not use this file except in compliance with the License.
+%% You may obtain a copy of the License at
+%%
+%% http://www.apache.org/licenses/LICENSE-2.0
+%%
+%% Unless required by applicable law or agreed to in writing, software
+%% distributed under the License is distributed on an "AS IS" BASIS,
+%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+%% See the License for the specific language governing permissions and
+%% limitations under the License.
+%%
+%% %CopyrightEnd%
+
+%% Options used when adding files to a tar archive.
+-record(add_opts, {
+ read_info, %% Fun to use for read file/link info.
+ chunk_size = 0, %% For file reading when sending to sftp. 0=do not chunk
+ verbose = false}). %% Verbose on/off.
+-type add_opts() :: #add_opts{}.
+
+%% Options used when reading a tar archive.
+-record(read_opts, {
+ cwd :: string(), %% Current working directory.
+ keep_old_files = false :: boolean(), %% Owerwrite or not.
+ files = all, %% Set of files to extract (or all)
+ output = file :: 'file' | 'memory',
+ open_mode = [], %% Open mode options.
+ verbose = false :: boolean()}). %% Verbose on/off.
+-type read_opts() :: #read_opts{}.
+
+-type add_opt() :: dereference |
+ verbose |
+ {chunks, pos_integer()}.
+
+-type extract_opt() :: {cwd, string()} |
+ {files, [string()]} |
+ compressed |
+ cooked |
+ memory |
+ keep_old_files |
+ verbose.
+
+-type create_opt() :: compressed |
+ cooked |
+ dereference |
+ verbose.
+
+-type filelist() :: [file:filename() |
+ {string(), binary()} |
+ {string(), file:filename()}].
+
+-type tar_time() :: non_neg_integer().
+
+%% The tar header, once fully parsed.
+-record(tar_header, {
+ name = "" :: string(), %% name of header file entry
+ mode = 8#100644 :: non_neg_integer(), %% permission and mode bits
+ uid = 0 :: non_neg_integer(), %% user id of owner
+ gid = 0 :: non_neg_integer(), %% group id of owner
+ size = 0 :: non_neg_integer(), %% length in bytes
+ mtime :: tar_time(), %% modified time
+ typeflag :: char(), %% type of header entry
+ linkname = "" :: string(), %% target name of link
+ uname = "" :: string(), %% user name of owner
+ gname = "" :: string(), %% group name of owner
+ devmajor = 0 :: non_neg_integer(), %% major number of character or block device
+ devminor = 0 :: non_neg_integer(), %% minor number of character or block device
+ atime :: tar_time(), %% access time
+ ctime :: tar_time() %% status change time
+ }).
+-type tar_header() :: #tar_header{}.
+
+%% Metadata for a sparse file fragment
+-record(sparse_entry, {
+ offset = 0 :: non_neg_integer(),
+ num_bytes = 0 :: non_neg_integer()}).
+-type sparse_entry() :: #sparse_entry{}.
+%% Contains metadata about fragments of a sparse file
+-record(sparse_array, {
+ entries = [] :: [sparse_entry()],
+ is_extended = false :: boolean(),
+ max_entries = 0 :: non_neg_integer()}).
+-type sparse_array() :: #sparse_array{}.
+%% A subset of tar header fields common to all tar implementations
+-record(header_v7, {
+ name :: binary(),
+ mode :: binary(), %% octal
+ uid :: binary(), %% integer
+ gid :: binary(), %% integer
+ size :: binary(), %% integer
+ mtime :: binary(), %% integer
+ checksum :: binary(), %% integer
+ typeflag :: byte(), %% char
+ linkname :: binary()}).
+-type header_v7() :: #header_v7{}.
+%% The set of fields specific to GNU tar formatted archives
+-record(header_gnu, {
+ header_v7 :: header_v7(),
+ magic :: binary(),
+ version :: binary(),
+ uname :: binary(),
+ gname :: binary(),
+ devmajor :: binary(), %% integer
+ devminor :: binary(), %% integer
+ atime :: binary(), %% integer
+ ctime :: binary(), %% integer
+ sparse :: sparse_array(),
+ real_size :: binary()}). %% integer
+-type header_gnu() :: #header_gnu{}.
+%% The set of fields specific to STAR-formatted archives
+-record(header_star, {
+ header_v7 :: header_v7(),
+ magic :: binary(),
+ version :: binary(),
+ uname :: binary(),
+ gname :: binary(),
+ devmajor :: binary(), %% integer
+ devminor :: binary(), %% integer
+ prefix :: binary(),
+ atime :: binary(), %% integer
+ ctime :: binary(), %% integer
+ trailer :: binary()}).
+-type header_star() :: #header_star{}.
+%% The set of fields specific to USTAR-formatted archives
+-record(header_ustar, {
+ header_v7 :: header_v7(),
+ magic :: binary(),
+ version :: binary(),
+ uname :: binary(),
+ gname :: binary(),
+ devmajor :: binary(), %% integer
+ devminor :: binary(), %% integer
+ prefix :: binary()}).
+-type header_ustar() :: #header_ustar{}.
+
+-type header_fields() :: header_v7() |
+ header_gnu() |
+ header_star() |
+ header_ustar().
+
+%% The overall tar reader, it holds the low-level file handle,
+%% its access, position, and the I/O primitives wrapper.
+-record(reader, {
+ handle :: file:io_device() | term(),
+ access :: read | write | ram,
+ pos = 0 :: non_neg_integer(),
+ func :: file_op()
+ }).
+-type reader() :: #reader{}.
+%% A reader for a regular file within the tar archive,
+%% It tracks its current state relative to that file.
+-record(reg_file_reader, {
+ handle :: reader(),
+ num_bytes = 0,
+ pos = 0,
+ size = 0
+ }).
+-type reg_file_reader() :: #reg_file_reader{}.
+%% A reader for a sparse file within the tar archive,
+%% It tracks its current state relative to that file.
+-record(sparse_file_reader, {
+ handle :: reader(),
+ num_bytes = 0, %% bytes remaining
+ pos = 0, %% pos
+ size = 0, %% total size of file
+ sparse_map = #sparse_array{}
+ }).
+-type sparse_file_reader() :: #sparse_file_reader{}.
+
+%% Types for the readers
+-type reader_type() :: reader() | reg_file_reader() | sparse_file_reader().
+-type handle() :: file:io_device() | term().
+
+%% Type for the I/O primitive wrapper function
+-type file_op() :: fun((write | close | read2 | position,
+ {handle(), iodata()} | handle() | {handle(), non_neg_integer()}
+ | {handle(), non_neg_integer()}) ->
+ ok | eof | {ok, string() | binary()} | {ok, non_neg_integer()}
+ | {error, term()}).
+
+%% These constants (except S_IFMT) are
+%% used to determine what type of device
+%% a file is. Namely, `S_IFMT band file_info.mode`
+%% will equal one of these contants, and tells us
+%% which type it is. The stdlib file_info record
+%% does not differentiate between device types, and
+%% will not allow us to differentiate between sockets
+%% and named pipes. These constants are pulled from libc.
+-define(S_IFMT, 61440).
+-define(S_IFSOCK, 49152). %% socket
+-define(S_FIFO, 4096). %% fifo/named pipe
+-define(S_IFBLK, 24576). %% block device
+-define(S_IFCHR, 8192). %% character device
+
+%% Typeflag constants for the tar header
+-define(TYPE_REGULAR, $0). %% regular file
+-define(TYPE_REGULAR_A, 0). %% regular file
+-define(TYPE_LINK, $1). %% hard link
+-define(TYPE_SYMLINK, $2). %% symbolic link
+-define(TYPE_CHAR, $3). %% character device node
+-define(TYPE_BLOCK, $4). %% block device node
+-define(TYPE_DIR, $5). %% directory
+-define(TYPE_FIFO, $6). %% fifo node
+-define(TYPE_CONT, $7). %% reserved
+-define(TYPE_X_HEADER, $x). %% extended header
+-define(TYPE_X_GLOBAL_HEADER, $g). %% global extended header
+-define(TYPE_GNU_LONGNAME, $L). %% next file has a long name
+-define(TYPE_GNU_LONGLINK, $K). %% next file symlinks to a file with a long name
+-define(TYPE_GNU_SPARSE, $S). %% sparse file
+
+%% Mode constants from tar spec
+-define(MODE_ISUID, 4000). %% set uid
+-define(MODE_ISGID, 2000). %% set gid
+-define(MODE_ISVTX, 1000). %% save text (sticky bit)
+-define(MODE_ISDIR, 40000). %% directory
+-define(MODE_ISFIFO, 10000). %% fifo
+-define(MODE_ISREG, 100000). %% regular file
+-define(MODE_ISLNK, 120000). %% symbolic link
+-define(MODE_ISBLK, 60000). %% block special file
+-define(MODE_ISCHR, 20000). %% character special file
+-define(MODE_ISSOCK, 140000). %% socket
+
+%% Keywords for PAX extended header
+-define(PAX_ATIME, <<"atime">>).
+-define(PAX_CHARSET, <<"charset">>).
+-define(PAX_COMMENT, <<"comment">>).
+-define(PAX_CTIME, <<"ctime">>). %% ctime is not a valid pax header
+-define(PAX_GID, <<"gid">>).
+-define(PAX_GNAME, <<"gname">>).
+-define(PAX_LINKPATH, <<"linkpath">>).
+-define(PAX_MTIME, <<"mtime">>).
+-define(PAX_PATH, <<"path">>).
+-define(PAX_SIZE, <<"size">>).
+-define(PAX_UID, <<"uid">>).
+-define(PAX_UNAME, <<"uname">>).
+-define(PAX_XATTR, <<"SCHILY.xattr.">>).
+-define(PAX_XATTR_STR, "SCHILY.xattr.").
+-define(PAX_NONE, <<"">>).
+
+%% Tar format constants
+%% Unknown format
+-define(FORMAT_UNKNOWN, 0).
+%% The format of the original Unix V7 tar tool prior to standardization
+-define(FORMAT_V7, 1).
+%% The old and new GNU formats, incompatible with USTAR.
+%% This covers the old GNU sparse extension, but it does
+%% not cover the GNU sparse extensions using PAX headers,
+%% versions 0.0, 0.1, and 1.0; these fall under the PAX format.
+-define(FORMAT_GNU, 2).
+%% Schily's tar format, which is incompatible with USTAR.
+%% This does not cover STAR extensions to the PAX format; these
+%% fall under the PAX format.
+-define(FORMAT_STAR, 3).
+%% USTAR is the former standardization of tar defined in POSIX.1-1988,
+%% it is incompatible with the GNU and STAR formats.
+-define(FORMAT_USTAR, 4).
+%% PAX is the latest standardization of tar defined in POSIX.1-2001.
+%% This is an extension of USTAR and is "backwards compatible" with it.
+%%
+%% Some newer formats add their own extensions to PAX, such as GNU sparse
+%% files and SCHILY extended attributes. Since they are backwards compatible
+%% with PAX, they will be labelled as "PAX".
+-define(FORMAT_PAX, 5).
+
+%% Magic constants
+-define(MAGIC_GNU, <<"ustar ">>).
+-define(VERSION_GNU, <<" \x00">>).
+-define(MAGIC_USTAR, <<"ustar\x00">>).
+-define(VERSION_USTAR, <<"00">>).
+-define(TRAILER_STAR, <<"tar\x00">>).
+
+%% Size constants
+-define(BLOCK_SIZE, 512). %% size of each block in a tar stream
+-define(NAME_SIZE, 100). %% max length of the name field in USTAR format
+-define(PREFIX_SIZE, 155). %% max length of the prefix field in USTAR format
+
+%% Maximum size of a nanosecond value as an integer
+-define(MAX_NANO_INT_SIZE, 9).
+%% Maximum size of a 64-bit signed integer
+-define(MAX_INT64, (1 bsl 63 - 1)).
+
+-define(PAX_GNU_SPARSE_NUMBLOCKS, <<"GNU.sparse.numblocks">>).
+-define(PAX_GNU_SPARSE_OFFSET, <<"GNU.sparse.offset">>).
+-define(PAX_GNU_SPARSE_NUMBYTES, <<"GNU.sparse.numbytes">>).
+-define(PAX_GNU_SPARSE_MAP, <<"GNU.sparse.map">>).
+-define(PAX_GNU_SPARSE_NAME, <<"GNU.sparse.name">>).
+-define(PAX_GNU_SPARSE_MAJOR, <<"GNU.sparse.major">>).
+-define(PAX_GNU_SPARSE_MINOR, <<"GNU.sparse.minor">>).
+-define(PAX_GNU_SPARSE_SIZE, <<"GNU.sparse.size">>).
+-define(PAX_GNU_SPARSE_REALSIZE, <<"GNU.sparse.realsize">>).
+
+-define(V7_NAME, 0).
+-define(V7_NAME_LEN, 100).
+-define(V7_MODE, 100).
+-define(V7_MODE_LEN, 8).
+-define(V7_UID, 108).
+-define(V7_UID_LEN, 8).
+-define(V7_GID, 116).
+-define(V7_GID_LEN, 8).
+-define(V7_SIZE, 124).
+-define(V7_SIZE_LEN, 12).
+-define(V7_MTIME, 136).
+-define(V7_MTIME_LEN, 12).
+-define(V7_CHKSUM, 148).
+-define(V7_CHKSUM_LEN, 8).
+-define(V7_TYPE, 156).
+-define(V7_TYPE_LEN, 1).
+-define(V7_LINKNAME, 157).
+-define(V7_LINKNAME_LEN, 100).
+
+-define(STAR_TRAILER, 508).
+-define(STAR_TRAILER_LEN, 4).
+
+-define(USTAR_MAGIC, 257).
+-define(USTAR_MAGIC_LEN, 6).
+-define(USTAR_VERSION, 263).
+-define(USTAR_VERSION_LEN, 2).
+-define(USTAR_UNAME, 265).
+-define(USTAR_UNAME_LEN, 32).
+-define(USTAR_GNAME, 297).
+-define(USTAR_GNAME_LEN, 32).
+-define(USTAR_DEVMAJ, 329).
+-define(USTAR_DEVMAJ_LEN, 8).
+-define(USTAR_DEVMIN, 337).
+-define(USTAR_DEVMIN_LEN, 8).
+-define(USTAR_PREFIX, 345).
+-define(USTAR_PREFIX_LEN, 155).
+
+-define(GNU_MAGIC, 257).
+-define(GNU_MAGIC_LEN, 6).
+-define(GNU_VERSION, 263).
+-define(GNU_VERSION_LEN, 2).
+
+%% ?BLOCK_SIZE of zero-bytes.
+%% Two of these in a row mark the end of an archive.
+-define(ZERO_BLOCK, <<0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0>>).
+
+-define(BILLION, 1000000000).
+
+-define(EPOCH, {{1970,1,1}, {0,0,0}}).
diff --git a/lib/stdlib/src/error_logger_file_h.erl b/lib/stdlib/src/error_logger_file_h.erl
index 665685d3ee..b7c193f965 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-2016. 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]) ->
@@ -172,21 +164,6 @@ 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
true ->
@@ -227,17 +204,33 @@ string_p1([H|T]) when is_list(H) ->
string_p1([]) -> true;
string_p1(_) -> false.
-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)]).
+get_utc_config() ->
+ %% SASL utc_log configuration overrides stdlib config
+ %% in order to have uniform timestamps in log messages
+ case application:get_env(sasl, utc_log) of
+ {ok, Val} -> Val;
+ undefined ->
+ case application:get_env(stdlib, utc_log) of
+ {ok, Val} -> Val;
+ undefined -> false
+ end
+ end.
+
+header(Time, Title) ->
+ case get_utc_config() of
+ true ->
+ header(Time, Title, "UTC ");
+ _ ->
+ header(calendar:universal_time_to_local_time(Time), Title, "")
+ end.
+
+header({{Y,Mo,D},{H,Mi,S}}, Title, UTC) ->
+ io_lib:format("~n=~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));
-t(_) ->
- "".
+ t1(integer_to_list(X)).
+
t1([X]) -> [$0,X];
t1(X) -> X.
@@ -253,5 +246,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 cb22a8c0b6..8f0d7b0362 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-2016. All Rights Reserved.
+%% Copyright Ericsson AB 1996-2017. All Rights Reserved.
%%
%% Licensed under the Apache License, Version 2.0 (the "License");
%% you may not use this file except in compliance with the License.
@@ -44,7 +44,7 @@
%% This one is used when we takeover from the simple error_logger.
init({[], {error_logger, Buf}}) ->
User = set_group_leader(),
- Depth = get_depth(),
+ Depth = error_logger:get_format_depth(),
State = #st{user=User,prev_handler=error_logger,depth=Depth},
write_events(State, Buf),
{ok, State};
@@ -56,17 +56,9 @@ init({[], {error_logger_tty_h, PrevHandler}}) ->
%% This one is used when we are started directly.
init([]) ->
User = set_group_leader(),
- Depth = get_depth(),
+ Depth = error_logger:get_format_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.
-
handle_event({_Type, GL, _Msg}, State) when node(GL) =/= node() ->
{ok, State};
handle_event(Event, State) ->
@@ -128,13 +120,12 @@ write_events(State, [Ev|Es]) ->
write_events(_State, []) ->
ok.
-do_write_event(State, {Time0, Event}) ->
+do_write_event(State, {Time, Event}) ->
case parse_event(Event) of
ignore ->
ok;
- {Head,Pid,FormatList} ->
- Time = maybe_utc(Time0),
- Header = write_time(Time, Head),
+ {Title,Pid,FormatList} ->
+ Header = header(Time, Title),
Body = format_body(State, FormatList),
AtNode = if
node(Pid) =/= node() ->
@@ -142,7 +133,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;
@@ -197,21 +188,6 @@ 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
true ->
@@ -255,12 +231,29 @@ string_p1([H|T]) when is_list(H) ->
string_p1([]) -> true;
string_p1(_) -> false.
-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)]).
+get_utc_config() ->
+ %% SASL utc_log configuration overrides stdlib config
+ %% in order to have uniform timestamps in log messages
+ case application:get_env(sasl, utc_log) of
+ {ok, Val} -> Val;
+ undefined ->
+ case application:get_env(stdlib, utc_log) of
+ {ok, Val} -> Val;
+ undefined -> false
+ end
+ end.
+
+header(Time, Title) ->
+ case get_utc_config() of
+ true ->
+ header(Time, Title, "UTC ");
+ _ ->
+ header(calendar:universal_time_to_local_time(Time), Title, "")
+ end.
+
+header({{Y,Mo,D},{H,Mi,S}}, Title, UTC) ->
+ io_lib:format("~n=~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));
@@ -281,8 +274,3 @@ month(9) -> "Sep";
month(10) -> "Oct";
month(11) -> "Nov";
month(12) -> "Dec".
-
-
-
-
-
diff --git a/lib/stdlib/src/escript.erl b/lib/stdlib/src/escript.erl
index c42ae981e7..2093916a7c 100644
--- a/lib/stdlib/src/escript.erl
+++ b/lib/stdlib/src/escript.erl
@@ -1,7 +1,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 2007-2016. 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.
@@ -281,11 +281,12 @@ start(EscriptOptions) ->
end
catch
throw:Str ->
- io:format("escript: ~s\n", [Str]),
+ io:format("escript: ~ts\n", [Str]),
my_halt(127);
_:Reason ->
- io:format("escript: Internal error: ~p\n", [Reason]),
- io:format("~p\n", [erlang:get_stacktrace()]),
+ Stk = erlang:get_stacktrace(),
+ io:format("escript: Internal error: ~tp\n", [Reason]),
+ io:format("~tp\n", [Stk]),
my_halt(127)
end.
@@ -629,8 +630,7 @@ parse_source(S, File, Fd, StartLine, HeaderSz, CheckOnly) ->
{error, _} ->
epp_parse_file2(Epp, S2, [FileForm], OptModRes);
{eof, LastLine} ->
- Anno = anno(LastLine),
- S#state{forms_or_bin = [FileForm, {eof, Anno}]}
+ S#state{forms_or_bin = [FileForm, {eof, LastLine}]}
end,
ok = epp:close(Epp),
ok = file:close(Fd),
@@ -728,8 +728,7 @@ epp_parse_file2(Epp, S, Forms, Parsed) ->
[S#state.file,Ln,Mod:format_error(Args)]),
epp_parse_file(Epp, S#state{n_errors = S#state.n_errors + 1}, [Form | Forms]);
{eof, LastLine} ->
- Anno = anno(LastLine),
- S#state{forms_or_bin = lists:reverse([{eof, Anno} | Forms])}
+ S#state{forms_or_bin = lists:reverse([{eof, LastLine} | Forms])}
end.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
diff --git a/lib/stdlib/src/ets.erl b/lib/stdlib/src/ets.erl
index 20de06fd0b..898b2f5bba 100644
--- a/lib/stdlib/src/ets.erl
+++ b/lib/stdlib/src/ets.erl
@@ -1,7 +1,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 1996-2016. All Rights Reserved.
+%% Copyright Ericsson AB 1996-2017. All Rights Reserved.
%%
%% Licensed under the Apache License, Version 2.0 (the "License");
%% you may not use this file except in compliance with the License.
@@ -51,10 +51,10 @@
-type tab() :: atom() | tid().
-type type() :: set | ordered_set | bag | duplicate_bag.
-type continuation() :: '$end_of_table'
- | {tab(),integer(),integer(),binary(),list(),integer()}
- | {tab(),_,_,integer(),binary(),list(),integer(),integer()}.
+ | {tab(),integer(),integer(),comp_match_spec(),list(),integer()}
+ | {tab(),_,_,integer(),comp_match_spec(),list(),integer(),integer()}.
--opaque tid() :: integer().
+-opaque tid() :: reference().
-type match_pattern() :: atom() | tuple().
-type match_spec() :: [{match_pattern(), [_], [_]}].
@@ -70,15 +70,33 @@
match_object/2, match_object/3, match_spec_compile/1,
match_spec_run_r/3, member/2, new/2, next/2, prev/2,
rename/2, safe_fixtable/2, select/1, select/2, select/3,
- select_count/2, select_delete/2, select_reverse/1,
+ select_count/2, select_delete/2, select_replace/2, select_reverse/1,
select_reverse/2, select_reverse/3, setopts/2, slot/2,
take/2,
update_counter/3, update_counter/4, update_element/3]).
+%% internal exports
+-export([internal_request_all/0]).
+
-spec all() -> [Tab] when
Tab :: tab().
all() ->
+ receive_all(ets:internal_request_all(),
+ erlang:system_info(schedulers),
+ []).
+
+receive_all(_Ref, 0, All) ->
+ All;
+receive_all(Ref, N, All) ->
+ receive
+ {Ref, SchedAll} ->
+ receive_all(Ref, N-1, SchedAll ++ All)
+ end.
+
+-spec internal_request_all() -> reference().
+
+internal_request_all() ->
erlang:nif_error(undef).
-spec delete(Tab) -> true when
@@ -361,6 +379,14 @@ select_count(_, _) ->
select_delete(_, _) ->
erlang:nif_error(undef).
+-spec select_replace(Tab, MatchSpec) -> NumReplaced when
+ Tab :: tab(),
+ MatchSpec :: match_spec(),
+ NumReplaced :: non_neg_integer().
+
+select_replace(_, _) ->
+ erlang:nif_error(undef).
+
-spec select_reverse(Tab, MatchSpec) -> [Match] when
Tab :: tab(),
MatchSpec :: match_spec(),
@@ -488,7 +514,7 @@ update_element(_, _, _) ->
%%% End of BIFs
--opaque comp_match_spec() :: binary(). %% this one is REALLY opaque
+-opaque comp_match_spec() :: reference().
-spec match_spec_run(List, CompiledMatchSpec) -> list() when
List :: [tuple()],
@@ -505,28 +531,28 @@ match_spec_run(List, CompiledMS) ->
repair_continuation('$end_of_table', _) ->
'$end_of_table';
%% ordered_set
-repair_continuation(Untouched = {Table,Lastkey,EndCondition,N2,Bin,L2,N3,N4}, MS)
+repair_continuation(Untouched = {Table,Lastkey,EndCondition,N2,MSRef,L2,N3,N4}, MS)
when %% (is_atom(Table) or is_integer(Table)),
is_integer(N2),
- byte_size(Bin) =:= 0,
+ %% is_reference(MSRef),
is_list(L2),
is_integer(N3),
is_integer(N4) ->
- case ets:is_compiled_ms(Bin) of
+ case ets:is_compiled_ms(MSRef) of
true ->
Untouched;
false ->
{Table,Lastkey,EndCondition,N2,ets:match_spec_compile(MS),L2,N3,N4}
end;
%% set/bag/duplicate_bag
-repair_continuation(Untouched = {Table,N1,N2,Bin,L,N3}, MS)
+repair_continuation(Untouched = {Table,N1,N2,MSRef,L,N3}, MS)
when %% (is_atom(Table) or is_integer(Table)),
is_integer(N1),
is_integer(N2),
- byte_size(Bin) =:= 0,
+ %% is_reference(MSRef),
is_list(L),
is_integer(N3) ->
- case ets:is_compiled_ms(Bin) of
+ case ets:is_compiled_ms(MSRef) of
true ->
Untouched;
false ->
diff --git a/lib/stdlib/src/eval_bits.erl b/lib/stdlib/src/eval_bits.erl
index 80667023fb..631faa3be5 100644
--- a/lib/stdlib/src/eval_bits.erl
+++ b/lib/stdlib/src/eval_bits.erl
@@ -67,16 +67,20 @@ expr_grp([Field | FS], Bs0, Lf, Acc) ->
expr_grp([], Bs0, _Lf, Acc) ->
{value,Acc,Bs0}.
+eval_field({bin_element, _, {string, _, S}, {integer,_,8}, [integer,{unit,1},unsigned,big]}, Bs0, _Fun) ->
+ Latin1 = [C band 16#FF || C <- S],
+ {list_to_binary(Latin1),Bs0};
eval_field({bin_element, _, {string, _, S}, default, default}, Bs0, _Fun) ->
Latin1 = [C band 16#FF || C <- S],
{list_to_binary(Latin1),Bs0};
-eval_field({bin_element, Line, {string, _, S}, Size0, Options0}, Bs, _Fun) ->
- {_Size,[Type,_Unit,_Sign,Endian]} =
+eval_field({bin_element, Line, {string, _, S}, Size0, Options0}, Bs0, Fun) ->
+ {Size1,[Type,{unit,Unit},Sign,Endian]} =
make_bit_type(Line, Size0, Options0),
- Res = << <<(eval_exp_field1(C, no_size, no_unit,
- Type, Endian, no_sign))/binary>> ||
+ {value,Size,Bs1} = Fun(Size1, Bs0),
+ Res = << <<(eval_exp_field1(C, Size, Unit,
+ Type, Endian, Sign))/binary>> ||
C <- S >>,
- {Res,Bs};
+ {Res,Bs1};
eval_field({bin_element,Line,E,Size0,Options0}, Bs0, Fun) ->
{value,V,Bs1} = Fun(E, Bs0),
{Size1,[Type,{unit,Unit},Sign,Endian]} =
diff --git a/lib/stdlib/src/filelib.erl b/lib/stdlib/src/filelib.erl
index 7029389e2f..d7c313f214 100644
--- a/lib/stdlib/src/filelib.erl
+++ b/lib/stdlib/src/filelib.erl
@@ -1,7 +1,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 1997-2016. 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.
@@ -24,6 +24,7 @@
-export([fold_files/5, last_modified/1, file_size/1, ensure_dir/1]).
-export([wildcard/3, is_dir/2, is_file/2, is_regular/2]).
-export([fold_files/6, last_modified/2, file_size/2]).
+-export([find_file/2, find_file/3, find_source/1, find_source/2, find_source/3]).
%% For debugging/testing.
-export([compile_wildcard/1]).
@@ -517,3 +518,124 @@ 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
+ {"", ""},
+ {"ebin","src"},
+ {"ebin","esrc"}
+ ].
+
+basic_source_search_rules() ->
+ (erl_source_search_rules()
+ ++ c_source_search_rules()).
+
+erl_source_search_rules() ->
+ [{"ebin","src"}, {"ebin","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 -> error
+ end;
+ false ->
+ error
+ end.
diff --git a/lib/stdlib/src/filename.erl b/lib/stdlib/src/filename.erl
index 9eeba874e1..9bf4290916 100644
--- a/lib/stdlib/src/filename.erl
+++ b/lib/stdlib/src/filename.erl
@@ -19,6 +19,9 @@
%%
-module(filename).
+-deprecated({find_src,1,next_major_release}).
+-deprecated({find_src,2,next_major_release}).
+
%% Purpose: Provides generic manipulation of filenames.
%%
%% Generally, these functions accept filenames in the native format
@@ -34,9 +37,9 @@
-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,
+ rootname/1, rootname/2, split/1, flatten/1, nativename/1,
safe_relative_path/1]).
--export([find_src/1, find_src/2, flatten/1]).
+-export([find_src/1, find_src/2]). % deprecated
-export([basedir/2, basedir/3]).
%% Undocumented and unsupported exports.
@@ -784,7 +787,12 @@ climb(_, []) ->
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) --
@@ -827,14 +835,7 @@ climb(T, [_|Acc]) ->
| {'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
@@ -850,44 +851,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.
@@ -918,42 +922,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).
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 597830cf9a..32f43fc706 100644
--- a/lib/stdlib/src/gen.erl
+++ b/lib/stdlib/src/gen.erl
@@ -1,7 +1,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 1996-2016. All Rights Reserved.
+%% Copyright Ericsson AB 1996-2017. All Rights Reserved.
%%
%% Licensed under the Apache License, Version 2.0 (the "License");
%% you may not use this file except in compliance with the License.
@@ -26,7 +26,7 @@
%%%
%%% The standard behaviour should export init_it/6.
%%%-----------------------------------------------------------------
--export([start/5, start/6, debug_options/2,
+-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]).
@@ -408,6 +408,14 @@ spawn_opts(Options) ->
[]
end.
+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} ->
diff --git a/lib/stdlib/src/gen_event.erl b/lib/stdlib/src/gen_event.erl
index 0ded1e9fa6..da2b0da3ca 100644
--- a/lib/stdlib/src/gen_event.erl
+++ b/lib/stdlib/src/gen_event.erl
@@ -32,10 +32,12 @@
%%% Modified by Martin - uses proc_lib, sys and gen!
--export([start/0, start/1, start_link/0, start_link/1, stop/1, stop/3,
+-export([start/0, start/1, start/2,
+ start_link/0, start_link/1, start_link/2,
+ stop/1, stop/3,
notify/2, sync_notify/2,
add_handler/3, add_sup_handler/3, delete_handler/3, swap_handler/3,
- swap_sup_handler/3, which_handlers/1, call/3, call/4, wake_hib/4]).
+ swap_sup_handler/3, which_handlers/1, call/3, call/4, wake_hib/5]).
-export([init_it/6,
system_continue/3,
@@ -107,7 +109,8 @@
State :: term(),
Status :: term().
--optional_callbacks([format_status/2]).
+-optional_callbacks(
+ [handle_info/2, terminate/2, code_change/3, format_status/2]).
%%---------------------------------------------------------------------------
@@ -117,30 +120,64 @@
-type del_handler_ret() :: ok | term() | {'EXIT',term()}.
-type emgr_name() :: {'local', atom()} | {'global', atom()}
- | {'via', atom(), term()}.
+ | {'via', atom(), term()}.
+-type debug_flag() :: 'trace' | 'log' | 'statistics' | 'debug'
+ | {'logfile', string()}.
+-type option() :: {'timeout', timeout()}
+ | {'debug', [debug_flag()]}
+ | {'spawn_opt', [proc_lib:spawn_option()]}.
-type emgr_ref() :: atom() | {atom(), atom()} | {'global', atom()}
- | {'via', atom(), term()} | pid().
+ | {'via', atom(), term()} | pid().
-type start_ret() :: {'ok', pid()} | {'error', term()}.
%%---------------------------------------------------------------------------
-define(NO_CALLBACK, 'no callback module').
+%% -----------------------------------------------------------------
+%% Starts a generic event handler.
+%% start()
+%% start(MgrName | Options)
+%% start(MgrName, Options)
+%% start_link()
+%% start_link(MgrName | Options)
+%% start_link(MgrName, Options)
+%% MgrName ::= {local, atom()} | {global, atom()} | {via, atom(), term()}
+%% Options ::= [{timeout, Timeout} | {debug, [Flag]} | {spawn_opt,SOpts}]
+%% Flag ::= trace | log | {logfile, File} | statistics | debug
+%% (debug == log && statistics)
+%% Returns: {ok, Pid} |
+%% {error, {already_started, Pid}} |
+%% {error, Reason}
+%% -----------------------------------------------------------------
+
-spec start() -> start_ret().
start() ->
gen:start(?MODULE, nolink, ?NO_CALLBACK, [], []).
--spec start(emgr_name()) -> start_ret().
-start(Name) ->
- gen:start(?MODULE, nolink, Name, ?NO_CALLBACK, [], []).
+-spec start(emgr_name() | [option()]) -> start_ret().
+start(Name) when is_tuple(Name) ->
+ gen:start(?MODULE, nolink, Name, ?NO_CALLBACK, [], []);
+start(Options) when is_list(Options) ->
+ gen:start(?MODULE, nolink, ?NO_CALLBACK, [], Options).
+
+-spec start(emgr_name(), [option()]) -> start_ret().
+start(Name, Options) ->
+ gen:start(?MODULE, nolink, Name, ?NO_CALLBACK, [], Options).
-spec start_link() -> start_ret().
start_link() ->
gen:start(?MODULE, link, ?NO_CALLBACK, [], []).
--spec start_link(emgr_name()) -> start_ret().
-start_link(Name) ->
- gen:start(?MODULE, link, Name, ?NO_CALLBACK, [], []).
+-spec start_link(emgr_name() | [option()]) -> start_ret().
+start_link(Name) when is_tuple(Name) ->
+ gen:start(?MODULE, link, Name, ?NO_CALLBACK, [], []);
+start_link(Options) when is_list(Options) ->
+ gen:start(?MODULE, link, ?NO_CALLBACK, [], Options).
+
+-spec start_link(emgr_name(), [option()]) -> start_ret().
+start_link(Name, Options) ->
+ gen:start(?MODULE, link, Name, ?NO_CALLBACK, [], Options).
%% -spec init_it(pid(), 'self' | pid(), emgr_name(), module(), [term()], [_]) ->
init_it(Starter, self, Name, Mod, Args, Options) ->
@@ -149,8 +186,9 @@ init_it(Starter, Parent, Name0, _, _, Options) ->
process_flag(trap_exit, true),
Name = gen:name(Name0),
Debug = gen:debug_options(Name, Options),
+ HibernateAfterTimeout = gen:hibernate_after(Options),
proc_lib:init_ack(Starter, {ok, self()}),
- loop(Parent, Name, [], Debug, false).
+ 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}).
@@ -160,7 +198,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}).
@@ -193,7 +231,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.
@@ -227,81 +265,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) ->
@@ -355,18 +395,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,
@@ -375,12 +415,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},
@@ -392,7 +432,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
@@ -421,7 +461,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).
@@ -446,7 +486,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},
@@ -454,7 +494,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,
@@ -511,7 +551,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),
@@ -531,9 +571,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);
@@ -541,6 +581,10 @@ server_update(Handler1, Func, Event, SName) ->
do_terminate(Mod1, Handler1, remove_handler, State,
remove, SName, normal),
no;
+ {'EXIT', {undef, [{Mod1, handle_info, [_,_], _}|_]}} ->
+ error_logger:warning_msg("** Undefined handle_info in ~p~n"
+ "** Unhandled message: ~p~n", [Mod1, Event]),
+ {ok, Handler1};
Other ->
do_terminate(Mod1, Handler1, {error, Other}, State,
Event, SName, crash),
@@ -644,14 +688,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};
@@ -662,9 +706,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);
@@ -686,7 +736,7 @@ report_error(_Handler, normal, _, _, _) -> ok;
report_error(_Handler, shutdown, _, _, _) -> ok;
report_error(_Handler, {swapped,_,_}, _, _, _) -> ok;
report_error(Handler, Reason, State, LastIn, SName) ->
- Reason1 =
+ Reason1 =
case Reason of
{'EXIT',{undef,[{M,F,A,L}|MFAs]}} ->
case code:is_loaded(M) of
@@ -751,7 +801,7 @@ get_modules(MSL) ->
%% Status information
%%-----------------------------------------------------------------
format_status(Opt, StatusData) ->
- [PDict, SysState, Parent, _Debug, [ServerName, MSL, _Hib]] = StatusData,
+ [PDict, SysState, Parent, _Debug, [ServerName, MSL, _HibernateAfterTimeout, _Hib]] = StatusData,
Header = gen:format_status_header("Status for event handler",
ServerName),
FmtMSL = [case erlang:function_exported(Mod, format_status, 2) of
diff --git a/lib/stdlib/src/gen_fsm.erl b/lib/stdlib/src/gen_fsm.erl
index 6e7528fd98..9ef0ca818c 100644
--- a/lib/stdlib/src/gen_fsm.erl
+++ b/lib/stdlib/src/gen_fsm.erl
@@ -1,7 +1,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 1996-2016. 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.
@@ -113,7 +113,7 @@
sync_send_all_state_event/2, sync_send_all_state_event/3,
reply/2,
start_timer/2,send_event_after/2,cancel_timer/1,
- enter_loop/4, enter_loop/5, enter_loop/6, wake_hib/6]).
+ enter_loop/4, enter_loop/5, enter_loop/6, wake_hib/7]).
%% Internal exports
-export([init_it/6,
@@ -124,6 +124,26 @@
system_replace_state/2,
format_status/2]).
+-deprecated({start, 3, next_major_release}).
+-deprecated({start, 4, next_major_release}).
+-deprecated({start_link, 3, next_major_release}).
+-deprecated({start_link, 4, next_major_release}).
+-deprecated({stop, 1, next_major_release}).
+-deprecated({stop, 3, next_major_release}).
+-deprecated({send_event, 2, next_major_release}).
+-deprecated({sync_send_event, 2, next_major_release}).
+-deprecated({sync_send_event, 3, next_major_release}).
+-deprecated({send_all_state_event, 2, next_major_release}).
+-deprecated({sync_send_all_state_event, 2, next_major_release}).
+-deprecated({sync_send_all_state_event, 3, next_major_release}).
+-deprecated({reply, 2, next_major_release}).
+-deprecated({start_timer, 2, next_major_release}).
+-deprecated({send_event_after, 2, next_major_release}).
+-deprecated({cancel_timer, 1, next_major_release}).
+-deprecated({enter_loop, 4, next_major_release}).
+-deprecated({enter_loop, 5, next_major_release}).
+-deprecated({enter_loop, 6, next_major_release}).
+
-import(error_logger, [format/2]).
%%% ---------------------------------------------------
@@ -169,7 +189,8 @@
State :: term(),
Status :: term().
--optional_callbacks([format_status/2]).
+-optional_callbacks(
+ [handle_info/3, terminate/3, code_change/4, format_status/2]).
%%% ---------------------------------------------------
%%% Starts a generic state machine.
@@ -273,7 +294,7 @@ start_timer(Time, Msg) ->
send_event_after(Time, Event) ->
erlang:start_timer(Time, self(), {'$gen_event', Event}).
-%% Returns the remaing time for the timer if Ref referred to
+%% Returns the remaining time for the timer if Ref referred to
%% an active timer/send_event_after, false otherwise.
cancel_timer(Ref) ->
case erlang:cancel_timer(Ref) of
@@ -308,7 +329,8 @@ enter_loop(Mod, Options, StateName, StateData, ServerName, Timeout) ->
Name = gen:get_proc_name(ServerName),
Parent = gen:get_parent(),
Debug = gen:debug_options(Name, Options),
- loop(Parent, Name, StateName, StateData, Mod, Timeout, Debug).
+ HibernateAfterTimeout = gen:hibernate_after(Options),
+ loop(Parent, Name, StateName, StateData, Mod, Timeout, HibernateAfterTimeout, Debug).
%%% ---------------------------------------------------
%%% Initiate the new process.
@@ -322,13 +344,14 @@ init_it(Starter, self, Name, Mod, Args, Options) ->
init_it(Starter, Parent, Name0, Mod, Args, Options) ->
Name = gen:name(Name0),
Debug = gen:debug_options(Name, Options),
- case catch Mod:init(Args) of
+ 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} ->
gen:unregister_name(Name0),
proc_lib:init_ack(Starter, {error, Reason}),
@@ -350,68 +373,77 @@ init_it(Starter, Parent, Name0, Mod, Args, Options) ->
%%-----------------------------------------------------------------
%% 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
@@ -446,19 +478,19 @@ print_event(Dev, return, {Name, StateName}) ->
io:format(Dev, "*DBG* ~p switched to state ~w~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 ->
@@ -466,6 +498,10 @@ handle_msg(Msg, Parent, Name, StateName, StateData, Mod, _Time) -> %No debug her
StateName, NStateData, [])),
reply(From, Reply),
exit(R);
+ {'EXIT', {undef, [{Mod, handle_info, [_,_,_], _}|_]}} ->
+ error_logger:warning_msg("** Undefined handle_info in ~p~n"
+ "** Unhandled message: ~p~n", [Mod, Msg]),
+ loop(Parent, Name, StateName, StateData, Mod, infinity, HibernateAfterTimeout, []);
{'EXIT', What} ->
terminate(What, Name, Msg, Mod, StateName, StateData, []);
Reply ->
@@ -473,23 +509,23 @@ handle_msg(Msg, Parent, Name, StateName, StateData, Mod, _Time) -> %No debug her
Name, Msg, Mod, StateName, StateData, [])
end.
-handle_msg(Msg, Parent, Name, StateName, StateData, Mod, _Time, Debug) ->
+handle_msg(Msg, Parent, Name, StateName, StateData, Mod, _Time, HibernateAfterTimeout, Debug) ->
From = from(Msg),
case catch dispatch(Msg, Mod, StateName, StateData) of
{next_state, NStateName, NStateData} ->
Debug1 = sys:handle_debug(Debug, fun print_event/3,
{Name, NStateName}, return),
- loop(Parent, Name, NStateName, NStateData, Mod, infinity, Debug1);
+ loop(Parent, Name, NStateName, NStateData, Mod, infinity, HibernateAfterTimeout, Debug1);
{next_state, NStateName, NStateData, Time1} ->
Debug1 = sys:handle_debug(Debug, fun print_event/3,
{Name, NStateName}, return),
- loop(Parent, Name, NStateName, NStateData, Mod, Time1, Debug1);
+ loop(Parent, Name, NStateName, NStateData, Mod, Time1, HibernateAfterTimeout, Debug1);
{reply, Reply, NStateName, NStateData} when From =/= undefined ->
Debug1 = reply(Name, From, Reply, Debug, NStateName),
- loop(Parent, Name, NStateName, NStateData, Mod, infinity, Debug1);
+ loop(Parent, Name, NStateName, NStateData, Mod, infinity, HibernateAfterTimeout, Debug1);
{reply, Reply, NStateName, NStateData, Time1} when From =/= undefined ->
Debug1 = reply(Name, From, Reply, Debug, NStateName),
- loop(Parent, Name, NStateName, NStateData, Mod, Time1, Debug1);
+ loop(Parent, Name, NStateName, NStateData, Mod, Time1, HibernateAfterTimeout, Debug1);
{stop, Reason, NStateData} ->
terminate(Reason, Name, Msg, Mod, StateName, NStateData, Debug);
{stop, Reason, Reply, NStateData} when From =/= undefined ->
@@ -540,24 +576,30 @@ reply(Name, {To, Tag}, Reply, Debug, StateName) ->
-spec terminate(term(), _, _, atom(), _, _, _) -> no_return().
terminate(Reason, Name, Msg, Mod, StateName, StateData, Debug) ->
- case catch Mod:terminate(Reason, StateName, StateData) of
- {'EXIT', R} ->
- FmtStateData = format_status(terminate, Mod, get(), StateData),
- error_info(R, Name, Msg, StateName, FmtStateData, Debug),
- exit(R);
- _ ->
- case Reason of
- normal ->
- exit(normal);
- shutdown ->
- exit(shutdown);
- {shutdown,_}=Shutdown ->
- exit(Shutdown);
+ case erlang:function_exported(Mod, terminate, 3) of
+ true ->
+ case catch Mod:terminate(Reason, StateName, StateData) of
+ {'EXIT', R} ->
+ FmtStateData = format_status(terminate, Mod, get(), StateData),
+ error_info(R, Name, Msg, StateName, FmtStateData, Debug),
+ exit(R);
_ ->
- FmtStateData = format_status(terminate, Mod, get(), StateData),
- error_info(Reason,Name,Msg,StateName,FmtStateData,Debug),
- exit(Reason)
- end
+ ok
+ end;
+ false ->
+ ok
+ end,
+ case Reason of
+ normal ->
+ exit(normal);
+ shutdown ->
+ exit(shutdown);
+ {shutdown,_}=Shutdown ->
+ exit(Shutdown);
+ _ ->
+ FmtStateData1 = format_status(terminate, Mod, get(), StateData),
+ error_info(Reason,Name,Msg,StateName,FmtStateData1,Debug),
+ exit(Reason)
end.
error_info(Reason, Name, Msg, StateName, StateData, Debug) ->
@@ -614,7 +656,7 @@ get_msg(Msg) -> Msg.
%% Status information
%%-----------------------------------------------------------------
format_status(Opt, StatusData) ->
- [PDict, SysState, Parent, Debug, [Name, StateName, StateData, Mod, _Time]] =
+ [PDict, SysState, Parent, Debug, [Name, StateName, StateData, Mod, _Time, _HibernateAfterTimeout]] =
StatusData,
Header = gen:format_status_header("Status for state machine",
Name),
diff --git a/lib/stdlib/src/gen_server.erl b/lib/stdlib/src/gen_server.erl
index 5800aca66f..a3d53efd0d 100644
--- a/lib/stdlib/src/gen_server.erl
+++ b/lib/stdlib/src/gen_server.erl
@@ -1,7 +1,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 1996-2016. All Rights Reserved.
+%% Copyright Ericsson AB 1996-2017. All Rights Reserved.
%%
%% Licensed under the Apache License, Version 2.0 (the "License");
%% you may not use this file except in compliance with the License.
@@ -94,7 +94,7 @@
cast/2, reply/2,
abcast/2, abcast/3,
multi_call/2, multi_call/3, multi_call/4,
- enter_loop/3, enter_loop/4, enter_loop/5, wake_hib/5]).
+ enter_loop/3, enter_loop/4, enter_loop/5, wake_hib/6]).
%% System exports
-export([system_continue/3,
@@ -107,7 +107,9 @@
%% Internal exports
-export([init_it/6]).
--import(error_logger, [format/2]).
+-define(
+ STACKTRACE(),
+ try throw(ok) catch _ -> erlang:get_stacktrace() end).
%%%=========================================================================
%%% API
@@ -146,8 +148,8 @@
State :: term(),
Status :: term().
--optional_callbacks([format_status/2]).
-
+-optional_callbacks(
+ [handle_info/2, terminate/2, code_change/3, format_status/2]).
%%% -----------------------------------------------------------------
%%% Starts a generic server.
@@ -307,7 +309,8 @@ enter_loop(Mod, Options, State, ServerName, Timeout) ->
Name = gen:get_proc_name(ServerName),
Parent = gen:get_parent(),
Debug = gen:debug_options(Name, Options),
- loop(Parent, Name, State, Mod, Timeout, Debug).
+ HibernateAfterTimeout = gen:hibernate_after(Options),
+ loop(Parent, Name, State, Mod, Timeout, HibernateAfterTimeout, Debug).
%%%========================================================================
%%% Gen-callback functions
@@ -325,14 +328,16 @@ init_it(Starter, self, Name, Mod, Args, Options) ->
init_it(Starter, Parent, Name0, Mod, Args, Options) ->
Name = gen:name(Name0),
Debug = gen:debug_options(Name, Options),
- case catch Mod:init(Args) of
- {ok, State} ->
+ 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.
@@ -342,18 +347,25 @@ init_it(Starter, Parent, Name0, Mod, Args, Options) ->
gen:unregister_name(Name0),
proc_lib:init_ack(Starter, {error, Reason}),
exit(Reason);
- ignore ->
+ {ok, ignore} ->
gen:unregister_name(Name0),
proc_lib:init_ack(Starter, ignore),
exit(normal);
- {'EXIT', Reason} ->
- gen:unregister_name(Name0),
- proc_lib:init_ack(Starter, {error, Reason}),
- exit(Reason);
- Else ->
+ {ok, Else} ->
Error = {bad_return_value, Else},
proc_lib:init_ack(Starter, {error, Error}),
- exit(Error)
+ exit(Error);
+ {'EXIT', Class, Reason, Stacktrace} ->
+ gen:unregister_name(Name0),
+ proc_lib:init_ack(Starter, {error, terminate_reason(Class, Reason, Stacktrace)}),
+ erlang:raise(Class, Reason, Stacktrace)
+ end.
+init_it(Mod, Args) ->
+ try
+ {ok, Mod:init(Args)}
+ catch
+ throw:R -> {ok, R};
+ Class:R -> {'EXIT', Class, R, erlang:get_stacktrace()}
end.
%%%========================================================================
@@ -362,37 +374,46 @@ init_it(Starter, Parent, Name0, Mod, Args, Options) ->
%%% ---------------------------------------------------
%%% The MAIN loop.
%%% ---------------------------------------------------
-loop(Parent, Name, State, Mod, hibernate, Debug) ->
- proc_lib:hibernate(?MODULE,wake_hib,[Parent, Name, State, Mod, Debug]);
-loop(Parent, Name, State, Mod, Time, Debug) ->
+loop(Parent, Name, State, Mod, hibernate, HibernateAfterTimeout, Debug) ->
+ proc_lib:hibernate(?MODULE,wake_hib,[Parent, Name, State, Mod, HibernateAfterTimeout, Debug]);
+
+loop(Parent, Name, State, Mod, infinity, HibernateAfterTimeout, Debug) ->
+ receive
+ Msg ->
+ decode_msg(Msg, Parent, Name, State, Mod, infinity, HibernateAfterTimeout, Debug, false)
+ after HibernateAfterTimeout ->
+ loop(Parent, Name, State, Mod, hibernate, HibernateAfterTimeout, Debug)
+ end;
+
+loop(Parent, Name, State, Mod, Time, HibernateAfterTimeout, Debug) ->
Msg = receive
Input ->
Input
after Time ->
timeout
end,
- decode_msg(Msg, Parent, Name, State, Mod, Time, Debug, false).
+ decode_msg(Msg, Parent, Name, State, Mod, Time, HibernateAfterTimeout, Debug, false).
-wake_hib(Parent, Name, State, Mod, Debug) ->
+wake_hib(Parent, Name, State, Mod, HibernateAfterTimeout, Debug) ->
Msg = receive
Input ->
Input
end,
- decode_msg(Msg, Parent, Name, State, Mod, hibernate, Debug, true).
+ decode_msg(Msg, Parent, Name, State, Mod, hibernate, HibernateAfterTimeout, Debug, true).
-decode_msg(Msg, Parent, Name, State, Mod, Time, Debug, Hib) ->
+decode_msg(Msg, Parent, Name, State, Mod, Time, HibernateAfterTimeout, Debug, Hib) ->
case Msg of
{system, From, Req} ->
sys:handle_system_msg(Req, From, Parent, ?MODULE, Debug,
- [Name, State, Mod, Time], Hib);
+ [Name, State, Mod, Time, HibernateAfterTimeout], Hib);
{'EXIT', Parent, Reason} ->
- terminate(Reason, Name, Msg, Mod, State, Debug);
+ terminate(Reason, ?STACKTRACE(), Name, undefined, Msg, Mod, State, Debug);
_Msg when Debug =:= [] ->
- handle_msg(Msg, Parent, Name, State, Mod);
+ handle_msg(Msg, Parent, Name, State, Mod, HibernateAfterTimeout);
_Msg ->
Debug1 = sys:handle_debug(Debug, fun print_event/3,
Name, {in, Msg}),
- handle_msg(Msg, Parent, Name, State, Mod, Debug1)
+ handle_msg(Msg, Parent, Name, State, Mod, HibernateAfterTimeout, Debug1)
end.
%%% ---------------------------------------------------
@@ -578,17 +599,11 @@ start_monitor(Node, Name) when is_atom(Node), is_atom(Name) ->
%% ---------------------------------------------------
%% Helper functions for try-catch of callbacks.
%% Returns the return value of the callback, or
-%% {'EXIT', ExitReason, ReportReason} (if an exception occurs)
-%%
-%% ExitReason is the reason that shall be used when the process
-%% terminates.
-%%
-%% ReportReason is the reason that shall be printed in the error
-%% report.
+%% {'EXIT', Class, Reason, Stack} (if an exception occurs)
%%
-%% 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) ->
@@ -602,12 +617,18 @@ try_dispatch(Mod, Func, Msg, State) ->
catch
throw:R ->
{ok, R};
- error:R ->
- Stacktrace = erlang:get_stacktrace(),
- {'EXIT', {R, Stacktrace}, {R, Stacktrace}};
- exit:R ->
- Stacktrace = erlang:get_stacktrace(),
- {'EXIT', R, {R, Stacktrace}}
+ error:undef = R when Func == handle_info ->
+ case erlang:function_exported(Mod, handle_info, 2) of
+ false ->
+ error_logger:warning_msg("** Undefined handle_info in ~p~n"
+ "** Unhandled message: ~p~n",
+ [Mod, Msg]),
+ {ok, {noreply, State}};
+ true ->
+ {'EXIT', error, R, erlang:get_stacktrace()}
+ end;
+ Class:R ->
+ {'EXIT', Class, R, erlang:get_stacktrace()}
end.
try_handle_call(Mod, Msg, From, State) ->
@@ -616,26 +637,23 @@ try_handle_call(Mod, Msg, From, State) ->
catch
throw:R ->
{ok, R};
- error:R ->
- Stacktrace = erlang:get_stacktrace(),
- {'EXIT', {R, Stacktrace}, {R, Stacktrace}};
- exit:R ->
- Stacktrace = erlang:get_stacktrace(),
- {'EXIT', R, {R, Stacktrace}}
+ Class:R ->
+ {'EXIT', Class, R, erlang:get_stacktrace()}
end.
try_terminate(Mod, Reason, State) ->
- try
- {ok, Mod:terminate(Reason, State)}
- catch
- throw:R ->
- {ok, R};
- error:R ->
- Stacktrace = erlang:get_stacktrace(),
- {'EXIT', {R, Stacktrace}, {R, Stacktrace}};
- exit:R ->
- Stacktrace = erlang:get_stacktrace(),
- {'EXIT', R, {R, Stacktrace}}
+ case erlang:function_exported(Mod, terminate, 2) of
+ true ->
+ try
+ {ok, Mod:terminate(Reason, State)}
+ catch
+ throw:R ->
+ {ok, R};
+ Class:R ->
+ {'EXIT', Class, R, erlang:get_stacktrace()}
+ end;
+ false ->
+ {ok, ok}
end.
@@ -643,89 +661,91 @@ try_terminate(Mod, Reason, State) ->
%%% Message handling functions
%%% ---------------------------------------------------
-handle_msg({'$gen_call', From, Msg}, Parent, Name, State, Mod) ->
+handle_msg({'$gen_call', From, Msg}, Parent, Name, State, Mod, HibernateAfterTimeout) ->
Result = try_handle_call(Mod, Msg, From, State),
case Result of
{ok, {reply, Reply, NState}} ->
reply(From, Reply),
- loop(Parent, Name, NState, Mod, infinity, []);
+ loop(Parent, Name, NState, Mod, infinity, HibernateAfterTimeout, []);
{ok, {reply, Reply, NState, Time1}} ->
reply(From, Reply),
- loop(Parent, Name, NState, Mod, Time1, []);
+ loop(Parent, Name, NState, Mod, Time1, HibernateAfterTimeout, []);
{ok, {noreply, NState}} ->
- loop(Parent, Name, NState, Mod, infinity, []);
+ loop(Parent, Name, NState, Mod, infinity, HibernateAfterTimeout, []);
{ok, {noreply, NState, Time1}} ->
- loop(Parent, Name, NState, Mod, Time1, []);
+ loop(Parent, Name, NState, Mod, Time1, HibernateAfterTimeout, []);
{ok, {stop, Reason, Reply, NState}} ->
- {'EXIT', R} =
- (catch terminate(Reason, Name, Msg, Mod, NState, [])),
- reply(From, Reply),
- exit(R);
- Other -> handle_common_reply(Other, Parent, Name, Msg, Mod, State)
+ try
+ terminate(Reason, ?STACKTRACE(), Name, From, Msg, Mod, NState, [])
+ after
+ reply(From, Reply)
+ end;
+ Other -> handle_common_reply(Other, Parent, Name, From, Msg, Mod, HibernateAfterTimeout, State)
end;
-handle_msg(Msg, Parent, Name, State, Mod) ->
+handle_msg(Msg, Parent, Name, State, Mod, HibernateAfterTimeout) ->
Reply = try_dispatch(Msg, Mod, State),
- handle_common_reply(Reply, Parent, Name, Msg, Mod, State).
+ handle_common_reply(Reply, Parent, Name, undefined, Msg, Mod, HibernateAfterTimeout, State).
-handle_msg({'$gen_call', From, Msg}, Parent, Name, State, Mod, Debug) ->
+handle_msg({'$gen_call', From, Msg}, Parent, Name, State, Mod, HibernateAfterTimeout, Debug) ->
Result = try_handle_call(Mod, Msg, From, State),
case Result of
{ok, {reply, Reply, NState}} ->
Debug1 = reply(Name, From, Reply, NState, Debug),
- loop(Parent, Name, NState, Mod, infinity, Debug1);
+ loop(Parent, Name, NState, Mod, infinity, HibernateAfterTimeout, Debug1);
{ok, {reply, Reply, NState, Time1}} ->
Debug1 = reply(Name, From, Reply, NState, Debug),
- loop(Parent, Name, NState, Mod, Time1, Debug1);
+ loop(Parent, Name, NState, Mod, Time1, HibernateAfterTimeout, Debug1);
{ok, {noreply, NState}} ->
Debug1 = sys:handle_debug(Debug, fun print_event/3, Name,
{noreply, NState}),
- loop(Parent, Name, NState, Mod, infinity, Debug1);
+ loop(Parent, Name, NState, Mod, infinity, HibernateAfterTimeout, Debug1);
{ok, {noreply, NState, Time1}} ->
Debug1 = sys:handle_debug(Debug, fun print_event/3, Name,
{noreply, NState}),
- loop(Parent, Name, NState, Mod, Time1, Debug1);
+ loop(Parent, Name, NState, Mod, Time1, HibernateAfterTimeout, Debug1);
{ok, {stop, Reason, Reply, NState}} ->
- {'EXIT', R} =
- (catch terminate(Reason, Name, Msg, Mod, NState, Debug)),
- _ = reply(Name, From, Reply, NState, Debug),
- exit(R);
+ try
+ terminate(Reason, ?STACKTRACE(), Name, From, Msg, Mod, NState, Debug)
+ after
+ _ = reply(Name, From, Reply, NState, Debug)
+ end;
Other ->
- handle_common_reply(Other, Parent, Name, Msg, Mod, State, Debug)
+ handle_common_reply(Other, Parent, Name, From, Msg, Mod, HibernateAfterTimeout, State, Debug)
end;
-handle_msg(Msg, Parent, Name, State, Mod, Debug) ->
+handle_msg(Msg, Parent, Name, State, Mod, HibernateAfterTimeout, Debug) ->
Reply = try_dispatch(Msg, Mod, State),
- handle_common_reply(Reply, Parent, Name, Msg, Mod, State, Debug).
+ handle_common_reply(Reply, Parent, Name, undefined, Msg, Mod, HibernateAfterTimeout, State, Debug).
-handle_common_reply(Reply, Parent, Name, Msg, Mod, State) ->
+handle_common_reply(Reply, Parent, Name, From, Msg, Mod, HibernateAfterTimeout, State) ->
case Reply of
{ok, {noreply, NState}} ->
- loop(Parent, Name, NState, Mod, infinity, []);
+ loop(Parent, Name, NState, Mod, infinity, HibernateAfterTimeout, []);
{ok, {noreply, NState, Time1}} ->
- loop(Parent, Name, NState, Mod, Time1, []);
+ loop(Parent, Name, NState, Mod, Time1, HibernateAfterTimeout, []);
{ok, {stop, Reason, NState}} ->
- terminate(Reason, Name, Msg, Mod, NState, []);
- {'EXIT', ExitReason, ReportReason} ->
- terminate(ExitReason, ReportReason, Name, Msg, Mod, State, []);
+ terminate(Reason, ?STACKTRACE(), Name, From, Msg, Mod, NState, []);
+ {'EXIT', Class, Reason, Stacktrace} ->
+ terminate(Class, Reason, Stacktrace, Name, From, Msg, Mod, State, []);
{ok, BadReply} ->
- terminate({bad_return_value, BadReply}, Name, Msg, Mod, State, [])
+ terminate({bad_return_value, BadReply}, ?STACKTRACE(), Name, From, Msg, Mod, State, [])
end.
-handle_common_reply(Reply, Parent, Name, Msg, Mod, State, Debug) ->
+handle_common_reply(Reply, Parent, Name, From, Msg, Mod, HibernateAfterTimeout, State, Debug) ->
case Reply of
{ok, {noreply, NState}} ->
Debug1 = sys:handle_debug(Debug, fun print_event/3, Name,
{noreply, NState}),
- loop(Parent, Name, NState, Mod, infinity, Debug1);
+ loop(Parent, Name, NState, Mod, infinity, HibernateAfterTimeout, Debug1);
{ok, {noreply, NState, Time1}} ->
Debug1 = sys:handle_debug(Debug, fun print_event/3, Name,
{noreply, NState}),
- loop(Parent, Name, NState, Mod, Time1, Debug1);
+ loop(Parent, Name, NState, Mod, Time1, HibernateAfterTimeout, Debug1);
{ok, {stop, Reason, NState}} ->
- terminate(Reason, Name, Msg, Mod, NState, Debug);
- {'EXIT', ExitReason, ReportReason} ->
- terminate(ExitReason, ReportReason, Name, Msg, Mod, State, Debug);
+ terminate(Reason, ?STACKTRACE(), Name, From, Msg, Mod, NState, Debug);
+ {'EXIT', Class, Reason, Stacktrace} ->
+ terminate(Class, Reason, Stacktrace, Name, From, Msg, Mod, State, Debug);
{ok, BadReply} ->
- terminate({bad_return_value, BadReply}, Name, Msg, Mod, State, Debug)
+ terminate({bad_return_value, BadReply}, ?STACKTRACE(), Name, From, Msg, Mod, State, Debug)
end.
reply(Name, {To, Tag}, Reply, State, Debug) ->
@@ -737,26 +757,26 @@ reply(Name, {To, Tag}, Reply, State, Debug) ->
%%-----------------------------------------------------------------
%% Callback functions for system messages handling.
%%-----------------------------------------------------------------
-system_continue(Parent, Debug, [Name, State, Mod, Time]) ->
- loop(Parent, Name, State, Mod, Time, Debug).
+system_continue(Parent, Debug, [Name, State, Mod, Time, HibernateAfterTimeout]) ->
+ loop(Parent, Name, State, Mod, Time, HibernateAfterTimeout, Debug).
-spec system_terminate(_, _, _, [_]) -> no_return().
-system_terminate(Reason, _Parent, Debug, [Name, State, Mod, _Time]) ->
- terminate(Reason, Name, [], Mod, State, Debug).
+system_terminate(Reason, _Parent, Debug, [Name, State, Mod, _Time, _HibernateAfterTimeout]) ->
+ terminate(Reason, ?STACKTRACE(), Name, undefined, [], Mod, State, Debug).
-system_code_change([Name, State, Mod, Time], _Module, OldVsn, Extra) ->
+system_code_change([Name, State, Mod, Time, HibernateAfterTimeout], _Module, OldVsn, Extra) ->
case catch Mod:code_change(OldVsn, State, Extra) of
- {ok, NewState} -> {ok, [Name, NewState, Mod, Time]};
+ {ok, NewState} -> {ok, [Name, NewState, Mod, Time, HibernateAfterTimeout]};
Else -> Else
end.
-system_get_state([_Name, State, _Mod, _Time]) ->
+system_get_state([_Name, State, _Mod, _Time, _HibernateAfterTimeout]) ->
{ok, State}.
-system_replace_state(StateFun, [Name, State, Mod, Time]) ->
+system_replace_state(StateFun, [Name, State, Mod, Time, HibernateAfterTimeout]) ->
NState = StateFun(State),
- {ok, NState, [Name, NState, Mod, Time]}.
+ {ok, NState, [Name, NState, Mod, Time, HibernateAfterTimeout]}.
%%-----------------------------------------------------------------
%% Format debug messages. Print them as the call-back module sees
@@ -784,41 +804,64 @@ print_event(Dev, Event, Name) ->
%%% ---------------------------------------------------
%%% 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(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(ExitReason, ReportReason, Name, Msg, Mod, State, Debug) ->
- Reply = try_terminate(Mod, ExitReason, State),
+-spec terminate(_, _, _, _, _, _, _, _, _, _) -> no_return().
+terminate(Class, Reason, Stacktrace, ReportReason, Name, From, Msg, Mod, State, Debug) ->
+ Reply = try_terminate(Mod, terminate_reason(Class, Reason, Stacktrace), State),
case Reply of
- {'EXIT', ExitReason1, ReportReason1} ->
+ {'EXIT', C, R, S} ->
FmtState = format_status(terminate, Mod, get(), State),
- error_info(ReportReason1, Name, Msg, FmtState, Debug),
- exit(ExitReason1);
+ error_info({R, S}, Name, From, Msg, FmtState, Debug),
+ erlang:raise(C, R, S);
_ ->
- case ExitReason of
- normal ->
- exit(normal);
- shutdown ->
- exit(shutdown);
- {shutdown,_}=Shutdown ->
- exit(Shutdown);
+ case {Class, Reason} of
+ {exit, normal} -> ok;
+ {exit, shutdown} -> ok;
+ {exit, {shutdown,_}} -> ok;
_ ->
FmtState = format_status(terminate, Mod, get(), State),
- error_info(ReportReason, Name, Msg, FmtState, Debug),
- exit(ExitReason)
+ error_info(ReportReason, Name, From, Msg, FmtState, Debug)
end
+ end,
+ case Stacktrace of
+ [] ->
+ erlang:Class(Reason);
+ _ ->
+ erlang:raise(Class, Reason, Stacktrace)
end.
-error_info(_Reason, application_controller, _Msg, _State, _Debug) ->
+terminate_reason(error, Reason, Stacktrace) -> {Reason, Stacktrace};
+terminate_reason(exit, Reason, _Stacktrace) -> Reason.
+
+error_info(_Reason, application_controller, _From, _Msg, _State, _Debug) ->
%% OTP-5811 Don't send an error report if it's the system process
%% application_controller which is terminating - let init take care
%% of it instead
ok;
-error_info(Reason, Name, Msg, State, Debug) ->
+error_info(Reason, Name, From, Msg, State, Debug) ->
Reason1 =
case Reason of
{undef,[{M,F,A,L}|MFAs]} ->
@@ -834,21 +877,42 @@ error_info(Reason, Name, Msg, State, Debug) ->
end
end;
_ ->
- Reason
+ error_logger:limit_term(Reason)
end,
- format("** Generic server ~p terminating \n"
- "** Last message in was ~p~n"
- "** When Server state == ~p~n"
- "** Reason for termination == ~n** ~p~n",
- [Name, Msg, State, Reason1]),
+ {ClientFmt, ClientArgs} = client_stacktrace(From),
+ LimitedState = error_logger:limit_term(State),
+ error_logger:format("** Generic server ~p terminating \n"
+ "** Last message in was ~p~n"
+ "** When Server state == ~p~n"
+ "** Reason for termination == ~n** ~p~n" ++ ClientFmt,
+ [Name, Msg, LimitedState, Reason1] ++ ClientArgs),
sys:print_log(Debug),
ok.
+client_stacktrace(undefined) ->
+ {"", []};
+client_stacktrace({From, _Tag}) ->
+ client_stacktrace(From);
+client_stacktrace(From) when is_pid(From), node(From) =:= node() ->
+ case process_info(From, [current_stacktrace, registered_name]) of
+ undefined ->
+ {"** Client ~p is dead~n", [From]};
+ [{current_stacktrace, Stacktrace}, {registered_name, []}] ->
+ {"** Client ~p stacktrace~n"
+ "** ~p~n",
+ [From, Stacktrace]};
+ [{current_stacktrace, Stacktrace}, {registered_name, Name}] ->
+ {"** Client ~p stacktrace~n"
+ "** ~p~n",
+ [Name, Stacktrace]}
+ end;
+client_stacktrace(From) when is_pid(From) ->
+ {"** Client ~p is remote on node ~p~n", [From, node(From)]}.
%%-----------------------------------------------------------------
%% Status information
%%-----------------------------------------------------------------
format_status(Opt, StatusData) ->
- [PDict, SysState, Parent, Debug, [Name, State, Mod, _Time]] = StatusData,
+ [PDict, SysState, Parent, Debug, [Name, State, Mod, _Time, _HibernateAfterTimeout]] = StatusData,
Header = gen:format_status_header("Status for generic server", Name),
Log = sys:get_debug(log, Debug, []),
Specfic = case format_status(Opt, Mod, PDict, State) of
diff --git a/lib/stdlib/src/gen_statem.erl b/lib/stdlib/src/gen_statem.erl
index cacc932ec4..b5e9da1e66 100644
--- a/lib/stdlib/src/gen_statem.erl
+++ b/lib/stdlib/src/gen_statem.erl
@@ -78,8 +78,9 @@
-type data() :: term().
-type event_type() ::
- {'call',From :: from()} | 'cast' |
- 'info' | 'timeout' | 'state_timeout' | 'internal'.
+ {'call',From :: from()} | 'cast' | 'info' |
+ 'timeout' | {'timeout', Name :: term()} | 'state_timeout' |
+ 'internal'.
-type callback_mode_result() ::
callback_mode() | [callback_mode() | state_enter()].
@@ -88,7 +89,7 @@
-type transition_option() ::
postpone() | hibernate() |
- event_timeout() | state_timeout().
+ event_timeout() | generic_timeout() | state_timeout().
-type postpone() ::
%% If 'true' postpone the current event
%% and retry it when the state changes (=/=)
@@ -97,13 +98,17 @@
%% If 'true' hibernate the server instead of going into receive
boolean().
-type event_timeout() ::
- %% Generate a ('timeout', EventContent, ...) event after Time
+ %% Generate a ('timeout', EventContent, ...) event
%% unless some other event is delivered
- Time :: timeout().
+ Time :: timeout() | integer().
+-type generic_timeout() ::
+ %% Generate a ({'timeout',Name}, EventContent, ...) event
+ Time :: timeout() | integer().
-type state_timeout() ::
- %% Generate a ('state_timeout', EventContent, ...) event after Time
+ %% Generate a ('state_timeout', EventContent, ...) event
%% unless the state is changed
- Time :: timeout().
+ Time :: timeout() | integer().
+-type timeout_option() :: {abs,Abs :: boolean()}.
-type action() ::
%% During a state change:
@@ -137,8 +142,24 @@
(Timeout :: event_timeout()) | % {timeout,Timeout}
{'timeout', % Set the event_timeout option
Time :: event_timeout(), EventContent :: term()} |
+ {'timeout', % Set the event_timeout option
+ Time :: event_timeout(),
+ EventContent :: term(),
+ Options :: (timeout_option() | [timeout_option()])} |
+ %%
+ {{'timeout', Name :: term()}, % Set the generic_timeout option
+ Time :: generic_timeout(), EventContent :: term()} |
+ {{'timeout', Name :: term()}, % Set the generic_timeout option
+ Time :: generic_timeout(),
+ EventContent :: term(),
+ Options :: (timeout_option() | [timeout_option()])} |
+ %%
{'state_timeout', % Set the state_timeout option
Time :: state_timeout(), EventContent :: term()} |
+ {'state_timeout', % Set the state_timeout option
+ Time :: state_timeout(),
+ EventContent :: term(),
+ Options :: (timeout_option() | [timeout_option()])} |
%%
reply_action().
-type reply_action() ::
@@ -287,8 +308,7 @@
StatusOption :: 'normal' | 'terminate'.
-optional_callbacks(
- [init/1, % One may use enter_loop/5,6,7 instead
- format_status/2, % Has got a default implementation
+ [format_status/2, % Has got a default implementation
terminate/3, % Has got a default implementation
code_change/4, % Only needed by advanced soft upgrade
%%
@@ -303,37 +323,26 @@
%% Type validation functions
callback_mode(CallbackMode) ->
case CallbackMode of
- state_functions ->
- true;
- handle_event_function ->
- true;
- _ ->
- false
+ state_functions -> true;
+ handle_event_function -> true;
+ _ -> false
end.
%%
-from({Pid,_}) when is_pid(Pid) ->
- true;
-from(_) ->
- false.
+from({Pid,_}) when is_pid(Pid) -> true;
+from(_) -> false.
%%
event_type({call,From}) ->
from(From);
event_type(Type) ->
case Type of
- {call,From} ->
- from(From);
- cast ->
- true;
- info ->
- true;
- timeout ->
- true;
- state_timeout ->
- true;
- internal ->
- true;
- _ ->
- false
+ {call,From} -> from(From);
+ cast -> true;
+ info -> true;
+ timeout -> true;
+ state_timeout -> true;
+ internal -> true;
+ {timeout,_} -> true;
+ _ -> false
end.
@@ -360,9 +369,12 @@ event_type(Type) ->
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()}.
@@ -535,14 +547,14 @@ reply({To,Tag}, Reply) when is_pid(To) ->
%% 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()],
+ 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()],
+ Module :: module(), Opts :: [debug_opt() | hibernate_after_opt()],
State :: state(), Data :: data(),
Server_or_Actions ::
server_name() | pid() | [action()]) ->
@@ -556,7 +568,7 @@ enter_loop(Module, Opts, State, Data, Server_or_Actions) ->
end.
%%
-spec enter_loop(
- Module :: module(), Opts :: [debug_opt()],
+ Module :: module(), Opts :: [debug_opt() | hibernate_after_opt()],
State :: state(), Data :: data(),
Server :: server_name() | pid(),
Actions :: [action()] | action()) ->
@@ -596,7 +608,8 @@ 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),
- Events = [],
+ HibernateAfterTimeout = gen:hibernate_after(Opts),
+ Events = [],
P = [],
Event = {internal,init_state},
%% We enforce {postpone,false} to ensure that
@@ -639,6 +652,7 @@ enter(Module, Opts, State, Data, Server, Actions, Parent) ->
timer_refs => TimerRefs,
timer_types => TimerTypes,
hibernate => Hibernate,
+ hibernate_after => HibernateAfterTimeout,
cancel_timers => CancelTimers
},
NewDebug = sys_debug(Debug, S, State, {enter,Event,State}),
@@ -845,7 +859,7 @@ loop_hibernate(Parent, Debug, S) ->
{wakeup_from_hibernate,3}}).
%% Entry point for wakeup_from_hibernate/3
-loop_receive(Parent, Debug, S) ->
+loop_receive(Parent, Debug, #{hibernate_after := HibernateAfterTimeout} = S) ->
receive
Msg ->
case Msg of
@@ -947,6 +961,9 @@ loop_receive(Parent, Debug, S) ->
loop_receive_result(
Parent, Debug, S, Hibernate, Event)
end
+ after
+ HibernateAfterTimeout ->
+ loop_hibernate(Parent, Debug, S)
end.
loop_receive_result(
@@ -1313,7 +1330,7 @@ parse_enter_actions(Debug, S, State, Actions, Hibernate, TimeoutsR) ->
parse_actions(Debug, S, State, Actions) ->
Hibernate = false,
- TimeoutsR = [{timeout,infinity,infinity}], %% Will cancel event timer
+ TimeoutsR = [infinity], %% Will cancel event timer
Postpone = false,
NextEventsR = [],
parse_actions(
@@ -1379,7 +1396,11 @@ parse_actions(
?STACKTRACE()}
end;
%%
- {state_timeout,_,_} = Timeout ->
+ {{timeout,_},_,_} = Timeout ->
+ parse_actions_timeout(
+ Debug, S, State, Actions,
+ Hibernate, TimeoutsR, Postpone, NextEventsR, Timeout);
+ {{timeout,_},_,_,_} = Timeout ->
parse_actions_timeout(
Debug, S, State, Actions,
Hibernate, TimeoutsR, Postpone, NextEventsR, Timeout);
@@ -1387,6 +1408,18 @@ parse_actions(
parse_actions_timeout(
Debug, S, State, Actions,
Hibernate, TimeoutsR, Postpone, NextEventsR, Timeout);
+ {timeout,_,_,_} = Timeout ->
+ parse_actions_timeout(
+ Debug, S, State, Actions,
+ Hibernate, TimeoutsR, Postpone, NextEventsR, Timeout);
+ {state_timeout,_,_} = Timeout ->
+ parse_actions_timeout(
+ Debug, S, State, Actions,
+ Hibernate, TimeoutsR, Postpone, NextEventsR, Timeout);
+ {state_timeout,_,_,_} = Timeout ->
+ parse_actions_timeout(
+ Debug, S, State, Actions,
+ Hibernate, TimeoutsR, Postpone, NextEventsR, Timeout);
Time ->
parse_actions_timeout(
Debug, S, State, Actions,
@@ -1396,26 +1429,64 @@ parse_actions(
parse_actions_timeout(
Debug, S, State, Actions,
Hibernate, TimeoutsR, Postpone, NextEventsR, Timeout) ->
- Time =
- case Timeout of
- {_,T,_} -> T;
- T -> T
- end,
- case validate_time(Time) of
- true ->
- parse_actions(
- Debug, S, State, Actions,
- Hibernate, [Timeout|TimeoutsR],
- Postpone, NextEventsR);
- false ->
- {error,
- {bad_action_from_state_function,Timeout},
- ?STACKTRACE()}
+ case Timeout of
+ {TimerType,Time,TimerMsg,TimerOpts} ->
+ case validate_timer_args(Time, listify(TimerOpts)) of
+ true ->
+ parse_actions(
+ Debug, S, State, Actions,
+ Hibernate, [Timeout|TimeoutsR],
+ Postpone, NextEventsR);
+ false ->
+ NewTimeout = {TimerType,Time,TimerMsg},
+ parse_actions(
+ Debug, S, State, Actions,
+ Hibernate, [NewTimeout|TimeoutsR],
+ Postpone, NextEventsR);
+ error ->
+ {error,
+ {bad_action_from_state_function,Timeout},
+ ?STACKTRACE()}
+ end;
+ {_,Time,_} ->
+ case validate_timer_args(Time, []) of
+ false ->
+ parse_actions(
+ Debug, S, State, Actions,
+ Hibernate, [Timeout|TimeoutsR],
+ Postpone, NextEventsR);
+ error ->
+ {error,
+ {bad_action_from_state_function,Timeout},
+ ?STACKTRACE()}
+ end;
+ Time ->
+ case validate_timer_args(Time, []) of
+ false ->
+ parse_actions(
+ Debug, S, State, Actions,
+ Hibernate, [Timeout|TimeoutsR],
+ Postpone, NextEventsR);
+ error ->
+ {error,
+ {bad_action_from_state_function,Timeout},
+ ?STACKTRACE()}
+ end
end.
-validate_time(Time) when is_integer(Time), Time >= 0 -> true;
-validate_time(infinity) -> true;
-validate_time(_) -> false.
+validate_timer_args(Time, Opts) ->
+ validate_timer_args(Time, Opts, false).
+%%
+validate_timer_args(Time, [], true) when is_integer(Time) ->
+ true;
+validate_timer_args(Time, [], false) when is_integer(Time), Time >= 0 ->
+ false;
+validate_timer_args(infinity, [], Abs) ->
+ Abs;
+validate_timer_args(Time, [{abs,Abs}|Opts], _) when is_boolean(Abs) ->
+ validate_timer_args(Time, Opts, Abs);
+validate_timer_args(_, [_|_], _) ->
+ error.
%% Stop and start timers as well as create timeout zero events
%% and pending event timer
@@ -1431,22 +1502,39 @@ parse_timers(
TimerRefs, TimerTypes, CancelTimers, [Timeout|TimeoutsR],
Seen, TimeoutEvents) ->
case Timeout of
+ {TimerType,Time,TimerMsg,TimerOpts} ->
+ %% Absolute timer
+ parse_timers(
+ TimerRefs, TimerTypes, CancelTimers, TimeoutsR,
+ Seen, TimeoutEvents,
+ TimerType, Time, TimerMsg, listify(TimerOpts));
+ %% Relative timers below
+ {TimerType,0,TimerMsg} ->
+ parse_timers(
+ TimerRefs, TimerTypes, CancelTimers, TimeoutsR,
+ Seen, TimeoutEvents,
+ TimerType, zero, TimerMsg, []);
{TimerType,Time,TimerMsg} ->
parse_timers(
- TimerRefs, TimerTypes, CancelTimers, TimeoutsR,
- Seen, TimeoutEvents,
- TimerType, Time, TimerMsg);
+ TimerRefs, TimerTypes, CancelTimers, TimeoutsR,
+ Seen, TimeoutEvents,
+ TimerType, Time, TimerMsg, []);
+ 0 ->
+ parse_timers(
+ TimerRefs, TimerTypes, CancelTimers, TimeoutsR,
+ Seen, TimeoutEvents,
+ timeout, zero, 0, []);
Time ->
parse_timers(
- TimerRefs, TimerTypes, CancelTimers, TimeoutsR,
- Seen, TimeoutEvents,
- timeout, Time, Time)
+ TimerRefs, TimerTypes, CancelTimers, TimeoutsR,
+ Seen, TimeoutEvents,
+ timeout, Time, Time, [])
end.
parse_timers(
TimerRefs, TimerTypes, CancelTimers, TimeoutsR,
Seen, TimeoutEvents,
- TimerType, Time, TimerMsg) ->
+ TimerType, Time, TimerMsg, TimerOpts) ->
case Seen of
#{TimerType := _} ->
%% Type seen before - ignore
@@ -1465,7 +1553,7 @@ parse_timers(
parse_timers(
TimerRefs, NewTimerTypes, NewCancelTimers, TimeoutsR,
NewSeen, TimeoutEvents);
- 0 ->
+ zero ->
%% Cancel any running timer
{NewTimerTypes,NewCancelTimers} =
cancel_timer_by_type(
@@ -1478,7 +1566,8 @@ parse_timers(
_ ->
%% (Re)start the timer
TimerRef =
- erlang:start_timer(Time, self(), TimerMsg),
+ erlang:start_timer(
+ Time, self(), TimerMsg, TimerOpts),
case TimerTypes of
#{TimerType := OldTimerRef} ->
%% Cancel the running timer
@@ -1492,6 +1581,8 @@ parse_timers(
NewCancelTimers, TimeoutsR,
NewSeen, TimeoutEvents);
#{} ->
+ %% Insert the new timer into
+ %% both TimerRefs and TimerTypes
parse_timers(
TimerRefs#{TimerRef => TimerType},
TimerTypes#{TimerType => TimerRef},
@@ -1631,6 +1722,8 @@ error_info(
end;
_ -> {Reason,Stacktrace}
end,
+ [LimitedP, LimitedFmtData, LimitedFixedReason] =
+ [error_logger:limit_term(D) || D <- [P, FmtData, FixedReason]],
CBMode =
case StateEnter of
true ->
@@ -1664,8 +1757,8 @@ error_info(
[] -> [];
[Event|_] -> [Event]
end] ++
- [FmtData,
- Class,FixedReason,
+ [LimitedFmtData,
+ Class,LimitedFixedReason,
CBMode] ++
case Q of
[_|[_|_] = Events] -> [Events];
@@ -1673,7 +1766,7 @@ error_info(
end ++
case P of
[] -> [];
- _ -> [P]
+ _ -> [LimitedP]
end ++
case FixedStacktrace of
[] -> [];
diff --git a/lib/stdlib/src/io_lib.erl b/lib/stdlib/src/io_lib.erl
index ad98bc0420..9d447418f8 100644
--- a/lib/stdlib/src/io_lib.erl
+++ b/lib/stdlib/src/io_lib.erl
@@ -1,7 +1,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 1996-2016. 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.
@@ -28,7 +28,7 @@
%% Most of the code here is derived from the original prolog versions and
%% from similar code written by Joe Armstrong and myself.
%%
-%% This module has been split into seperate modules:
+%% This module has been split into separate modules:
%% io_lib - basic write and utilities
%% io_lib_format - formatted output
%% io_lib_fread - formatted input
@@ -68,8 +68,8 @@
-export([write_atom/1,write_string/1,write_string/2,write_latin1_string/1,
write_latin1_string/2, write_char/1, write_latin1_char/1]).
--export([write_string_as_latin1/1, write_string_as_latin1/2,
- write_char_as_latin1/1]).
+-export([write_atom_as_latin1/1, write_string_as_latin1/1,
+ write_string_as_latin1/2, write_char_as_latin1/1]).
-export([quote_atom/2, char_list/1, latin1_char_list/1,
deep_char_list/1, deep_latin1_char_list/1,
@@ -84,6 +84,8 @@
-export([write_unicode_string/1, write_unicode_char/1,
deep_unicode_char_list/1]).
+-export([limit_term/2]).
+
-export_type([chars/0, latin1_string/0, continuation/0,
fread_error/0, fread_item/0, format_spec/0]).
@@ -268,47 +270,61 @@ write(Term, D, false) ->
-spec write(Term, Depth) -> chars() when
Term :: term(),
+ Depth :: depth();
+ (Term, Options) -> chars() when
+ Term :: term(),
+ Options :: [Option],
+ Option :: {'depth', Depth}
+ | {'encoding', 'latin1' | 'utf8' | 'unicode'},
Depth :: depth().
-write(_Term, 0) -> "...";
-write(Term, _D) when is_integer(Term) -> integer_to_list(Term);
-write(Term, _D) when is_float(Term) -> io_lib_format:fwrite_g(Term);
-write(Atom, _D) when is_atom(Atom) -> write_atom(Atom);
-write(Term, _D) when is_port(Term) -> write_port(Term);
-write(Term, _D) when is_pid(Term) -> pid_to_list(Term);
-write(Term, _D) when is_reference(Term) -> write_ref(Term);
-write(<<_/bitstring>>=Term, D) -> write_binary(Term, D);
-write([], _D) -> "[]";
-write({}, _D) -> "{}";
-write([H|T], D) ->
+write(Term, Options) when is_list(Options) ->
+ Depth = get_option(depth, Options, -1),
+ Encoding = get_option(encoding, Options, epp:default_encoding()),
+ write1(Term, Depth, Encoding);
+write(Term, Depth) ->
+ write1(Term, Depth, latin1).
+
+write1(_Term, 0, _E) -> "...";
+write1(Term, _D, _E) when is_integer(Term) -> integer_to_list(Term);
+write1(Term, _D, _E) when is_float(Term) -> io_lib_format:fwrite_g(Term);
+write1(Atom, _D, latin1) when is_atom(Atom) -> write_atom_as_latin1(Atom);
+write1(Atom, _D, _E) when is_atom(Atom) -> write_atom(Atom);
+write1(Term, _D, _E) when is_port(Term) -> write_port(Term);
+write1(Term, _D, _E) when is_pid(Term) -> pid_to_list(Term);
+write1(Term, _D, _E) when is_reference(Term) -> write_ref(Term);
+write1(<<_/bitstring>>=Term, D, _E) -> write_binary(Term, D);
+write1([], _D, _E) -> "[]";
+write1({}, _D, _E) -> "{}";
+write1([H|T], D, E) ->
if
D =:= 1 -> "[...]";
true ->
- [$[,[write(H, D-1)|write_tail(T, D-1, $|)],$]]
+ [$[,[write1(H, D-1, E)|write_tail(T, D-1, E, $|)],$]]
end;
-write(F, _D) when is_function(F) ->
+write1(F, _D, _E) when is_function(F) ->
erlang:fun_to_list(F);
-write(Term, D) when is_map(Term) ->
- write_map(Term, D);
-write(T, D) when is_tuple(T) ->
+write1(Term, D, E) when is_map(Term) ->
+ write_map(Term, D, E);
+write1(T, D, E) when is_tuple(T) ->
if
D =:= 1 -> "{...}";
true ->
[${,
- [write(element(1, T), D-1)|
- write_tail(tl(tuple_to_list(T)), D-1, $,)],
+ [write1(element(1, T), D-1, E)|
+ write_tail(tl(tuple_to_list(T)), D-1, E, $,)],
$}]
end.
%% write_tail(List, Depth, CharacterBeforeDots)
%% Test the terminating case first as this looks better with depth.
-write_tail([], _D, _S) -> "";
-write_tail(_, 1, S) -> [S | "..."];
-write_tail([H|T], D, S) ->
- [$,,write(H, D-1)|write_tail(T, D-1, S)];
-write_tail(Other, D, S) ->
- [S,write(Other, D-1)].
+write_tail([], _D, _E, _S) -> "";
+write_tail(_, 1, _E, S) -> [S | "..."];
+write_tail([H|T], D, E, S) ->
+ [$,,write1(H, D-1, E)|write_tail(T, D-1, E, S)];
+write_tail(Other, D, E, S) ->
+ [S,write1(Other, D-1, E)].
write_port(Port) ->
erlang:port_to_list(Port).
@@ -316,17 +332,17 @@ write_port(Port) ->
write_ref(Ref) ->
erlang:ref_to_list(Ref).
-write_map(Map, D) when is_integer(D) ->
- [$#,${,write_map_body(maps:to_list(Map), D),$}].
+write_map(Map, D, E) when is_integer(D) ->
+ [$#,${,write_map_body(maps:to_list(Map), D, E),$}].
-write_map_body(_, 0) -> "...";
-write_map_body([],_) -> [];
-write_map_body([{K,V}],D) -> write_map_assoc(K,V,D);
-write_map_body([{K,V}|KVs], D) ->
- [write_map_assoc(K,V,D),$, | write_map_body(KVs,D-1)].
+write_map_body(_, 0, _E) -> "...";
+write_map_body([], _, _E) -> [];
+write_map_body([{K,V}], D, E) -> write_map_assoc(K, V, D, E);
+write_map_body([{K,V}|KVs], D, E) ->
+ [write_map_assoc(K, V, D, E),$, | write_map_body(KVs, D-1, E)].
-write_map_assoc(K,V,D) ->
- [write(K,D - 1),"=>",write(V,D-1)].
+write_map_assoc(K, V, D, E) ->
+ [write1(K, D - 1, E),"=>",write1(V, D-1, E)].
write_binary(B, D) when is_integer(D) ->
[$<,$<,write_binary_body(B, D),$>,$>].
@@ -344,6 +360,18 @@ write_binary_body(B, _D) ->
<<X:L>> = B,
[integer_to_list(X),$:,integer_to_list(L)].
+get_option(Key, TupleList, Default) ->
+ case lists:keyfind(Key, 1, TupleList) of
+ false -> Default;
+ {Key, Value} -> Value;
+ _ -> Default
+ end.
+
+%%% There are two functions to write Unicode atoms:
+%%% - they both escape control characters < 160;
+%%% - write_atom() never escapes characters >= 160;
+%%% - write_atom_as_latin1() also escapes characters >= 255.
+
%% write_atom(Atom) -> [Char]
%% Generate the list of characters needed to print an atom.
@@ -351,17 +379,26 @@ write_binary_body(B, _D) ->
Atom :: atom().
write_atom(Atom) ->
+ write_possibly_quoted_atom(Atom, fun write_string/2).
+
+-spec write_atom_as_latin1(Atom) -> latin1_string() when
+ Atom :: atom().
+
+write_atom_as_latin1(Atom) ->
+ write_possibly_quoted_atom(Atom, fun write_string_as_latin1/2).
+
+write_possibly_quoted_atom(Atom, PFun) ->
Chars = atom_to_list(Atom),
case quote_atom(Atom, Chars) of
true ->
- write_string(Chars, $'); %'
+ PFun(Chars, $'); %'
false ->
Chars
end.
%% quote_atom(Atom, CharList)
%% Return 'true' if atom with chars in CharList needs to be quoted, else
-%% return 'false'.
+%% return 'false'. Notice that characters >= 160 are always quoted.
-spec quote_atom(atom(), chars()) -> boolean().
@@ -876,3 +913,116 @@ binrev(L) ->
binrev(L, T) ->
list_to_binary(lists:reverse(L, T)).
+
+-spec limit_term(term(), non_neg_integer()) -> term().
+
+%% The intention is to mimic the depth limitation of io_lib:write()
+%% and io_lib_pretty:print(). The leaves ('...') should never be
+%% seen when printed with the same depth. Bitstrings are never
+%% truncated, which is OK as long as they are not sent to other nodes.
+limit_term(Term, Depth) ->
+ try test_limit(Term, Depth) of
+ ok -> Term
+ catch
+ throw:limit ->
+ limit(Term, Depth)
+ end.
+
+limit(_, 0) -> '...';
+limit([H|T]=L, D) ->
+ if
+ D =:= 1 -> '...';
+ true ->
+ case printable_list(L) of
+ true -> L;
+ false ->
+ [limit(H, D-1)|limit_tail(T, D-1)]
+ end
+ end;
+limit(Term, D) when is_map(Term) ->
+ limit_map(Term, D);
+limit({}=T, _D) -> T;
+limit(T, D) when is_tuple(T) ->
+ if
+ D =:= 1 -> '...';
+ true ->
+ list_to_tuple([limit(element(1, T), D-1)|
+ limit_tail(tl(tuple_to_list(T)), D-1)])
+ end;
+limit(<<_/bitstring>>=Term, D) -> limit_bitstring(Term, D);
+limit(Term, _D) -> Term.
+
+limit_tail([], _D) -> [];
+limit_tail(_, 1) -> ['...'];
+limit_tail([H|T], D) ->
+ [limit(H, D-1)|limit_tail(T, D-1)];
+limit_tail(Other, D) ->
+ limit(Other, D-1).
+
+%% Cannot limit maps properly since there is no guarantee that
+%% maps:from_list() creates a map with the same internal ordering of
+%% the selected associations as in Map.
+limit_map(Map, D) ->
+ maps:from_list(erts_internal:maps_to_list(Map, D)).
+%% maps:from_list(limit_map_body(erts_internal:maps_to_list(Map, D), D)).
+
+%% limit_map_body(_, 0) -> [{'...', '...'}];
+%% limit_map_body([], _) -> [];
+%% limit_map_body([{K,V}], D) -> [limit_map_assoc(K, V, D)];
+%% limit_map_body([{K,V}|KVs], D) ->
+%% [limit_map_assoc(K, V, D) | limit_map_body(KVs, D-1)].
+
+%% limit_map_assoc(K, V, D) ->
+%% {limit(K, D-1), limit(V, D-1)}.
+
+limit_bitstring(B, _D) -> B. %% Keeps all printable binaries.
+
+test_limit(_, 0) -> throw(limit);
+test_limit([H|T]=L, D) when is_integer(D) ->
+ if
+ D =:= 1 -> throw(limit);
+ true ->
+ case printable_list(L) of
+ true -> ok;
+ false ->
+ test_limit(H, D-1),
+ test_limit_tail(T, D-1)
+ end
+ end;
+test_limit(Term, D) when is_map(Term) ->
+ test_limit_map(Term, D);
+test_limit({}, _D) -> ok;
+test_limit(T, D) when is_tuple(T) ->
+ test_limit_tuple(T, 1, tuple_size(T), D);
+test_limit(<<_/bitstring>>=Term, D) -> test_limit_bitstring(Term, D);
+test_limit(_Term, _D) -> ok.
+
+test_limit_tail([], _D) -> ok;
+test_limit_tail(_, 1) -> throw(limit);
+test_limit_tail([H|T], D) ->
+ test_limit(H, D-1),
+ test_limit_tail(T, D-1);
+test_limit_tail(Other, D) ->
+ test_limit(Other, D-1).
+
+test_limit_tuple(_T, I, Sz, _D) when I > Sz -> ok;
+test_limit_tuple(_, _, _, 1) -> throw(limit);
+test_limit_tuple(T, I, Sz, D) ->
+ test_limit(element(I, T), D-1),
+ test_limit_tuple(T, I+1, Sz, D-1).
+
+test_limit_map(_Map, _D) -> ok.
+%% test_limit_map_body(erts_internal:maps_to_list(Map, D), D).
+
+%% test_limit_map_body(_, 0) -> throw(limit);
+%% test_limit_map_body([], _) -> ok;
+%% test_limit_map_body([{K,V}], D) -> test_limit_map_assoc(K, V, D);
+%% test_limit_map_body([{K,V}|KVs], D) ->
+%% test_limit_map_assoc(K, V, D),
+%% test_limit_map_body(KVs, D-1).
+
+%% test_limit_map_assoc(K, V, D) ->
+%% test_limit(K, D-1),
+%% test_limit(V, D-1).
+
+test_limit_bitstring(_, _) -> ok.
diff --git a/lib/stdlib/src/io_lib_format.erl b/lib/stdlib/src/io_lib_format.erl
index 1da866dc88..4b2d15c8b3 100644
--- a/lib/stdlib/src/io_lib_format.erl
+++ b/lib/stdlib/src/io_lib_format.erl
@@ -1,7 +1,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 1996-2016. All Rights Reserved.
+%% Copyright Ericsson AB 1996-2017. All Rights Reserved.
%%
%% Licensed under the Apache License, Version 2.0 (the "License");
%% you may not use this file except in compliance with the License.
@@ -257,15 +257,18 @@ indentation([], I) -> I.
%% This is the main dispatch function for the various formatting commands.
%% Field widths and precisions have already been calculated.
-control($w, [A], F, Adj, P, Pad, _Enc, _Str, _I) ->
- term(io_lib:write(A, -1), F, Adj, P, Pad);
+control($w, [A], F, Adj, P, Pad, Enc, _Str, _I) ->
+ term(io_lib:write(A, [{depth,-1}, {encoding, Enc}]), F, Adj, P, Pad);
control($p, [A], F, Adj, P, Pad, Enc, Str, I) ->
print(A, -1, F, Adj, P, Pad, Enc, Str, I);
-control($W, [A,Depth], F, Adj, P, Pad, _Enc, _Str, _I) when is_integer(Depth) ->
- term(io_lib:write(A, Depth), F, Adj, P, Pad);
+control($W, [A,Depth], F, Adj, P, Pad, Enc, _Str, _I) when is_integer(Depth) ->
+ term(io_lib:write(A, [{depth,Depth}, {encoding, Enc}]), F, Adj, P, Pad);
control($P, [A,Depth], F, Adj, P, Pad, Enc, Str, I) when is_integer(Depth) ->
print(A, Depth, F, Adj, P, Pad, Enc, Str, I);
-control($s, [A], F, Adj, P, Pad, _Enc, _Str, _I) when is_atom(A) ->
+control($s, [A], F, Adj, P, Pad, latin1, _Str, _I) when is_atom(A) ->
+ L = iolist_to_chars(atom_to_list(A)),
+ string(L, F, Adj, P, Pad);
+control($s, [A], F, Adj, P, Pad, unicode, _Str, _I) when is_atom(A) ->
string(atom_to_list(A), F, Adj, P, Pad);
control($s, [L0], F, Adj, P, Pad, latin1, _Str, _I) ->
L = iolist_to_chars(L0),
@@ -332,7 +335,7 @@ base(B) when is_integer(B) ->
term(T, none, _Adj, none, _Pad) -> T;
term(T, none, Adj, P, Pad) -> term(T, P, Adj, P, Pad);
term(T, F, Adj, P0, Pad) ->
- L = lists:flatlength(T),
+ L = string:length(T),
P = erlang:min(L, case P0 of none -> F; _ -> min(P0, F) end),
if
L > P ->
@@ -343,7 +346,8 @@ term(T, F, Adj, P0, Pad) ->
%% print(Term, Depth, Field, Adjust, Precision, PadChar, Encoding,
%% Indentation)
-%% Print a term.
+%% Print a term. Field width sets maximum line length, Precision sets
+%% initial indentation.
print(T, D, none, Adj, P, Pad, E, Str, I) ->
print(T, D, 80, Adj, P, Pad, E, Str, I);
@@ -671,11 +675,11 @@ cdata_to_chars(B) when is_binary(B) ->
string(S, none, _Adj, none, _Pad) -> S;
string(S, F, Adj, none, Pad) ->
- string_field(S, F, Adj, lists:flatlength(S), Pad);
+ string_field(S, F, Adj, string:length(S), Pad);
string(S, none, _Adj, P, Pad) ->
- string_field(S, P, left, lists:flatlength(S), Pad);
+ string_field(S, P, left, string:length(S), Pad);
string(S, F, Adj, P, Pad) when F >= P ->
- N = lists:flatlength(S),
+ N = string:length(S),
if F > P ->
if N > P ->
adjust(flat_trunc(S, P), chars(Pad, F-P), Adj);
@@ -745,18 +749,7 @@ adjust(Data, Pad, right) -> [Pad|Data].
%% Flatten and truncate a deep list to at most N elements.
flat_trunc(List, N) when is_integer(N), N >= 0 ->
- flat_trunc(List, N, [], []).
-
-flat_trunc(L, 0, _, R) when is_list(L) ->
- lists:reverse(R);
-flat_trunc([H|T], N, S, R) when is_list(H) ->
- flat_trunc(H, N, [T|S], R);
-flat_trunc([H|T], N, S, R) ->
- flat_trunc(T, N-1, S, [H|R]);
-flat_trunc([], N, [H|S], R) ->
- flat_trunc(H, N, S, R);
-flat_trunc([], _, [], R) ->
- lists:reverse(R).
+ string:slice(List, 0, N).
%% A deep version of string:chars/2,3
diff --git a/lib/stdlib/src/io_lib_fread.erl b/lib/stdlib/src/io_lib_fread.erl
index 6a8f8f728e..983e8d4566 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-2016. 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.
@@ -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 ba2cffdcb3..505613b80e 100644
--- a/lib/stdlib/src/io_lib_pretty.erl
+++ b/lib/stdlib/src/io_lib_pretty.erl
@@ -97,31 +97,44 @@ print(Term, Col, Ll, D, RecDefFun) ->
print(Term, Col, Ll, D, M, RecDefFun) ->
print(Term, Col, Ll, D, M, RecDefFun, latin1, true).
+%% D = Depth, default -1 (infinite), or LINEMAX=30 when printing from shell
+%% Col = current column, default 1
+%% Ll = line length/~p field width, default 80
+%% M = CHAR_MAX (-1 if no max, 60 when printing from shell)
print(_, _, _, 0, _M, _RF, _Enc, _Str) -> "...";
print(Term, Col, Ll, D, M, RecDefFun, Enc, Str) when Col =< 0 ->
+ %% ensure Col is at least 1
print(Term, 1, Ll, D, M, RecDefFun, Enc, Str);
+print(Atom, _Col, _Ll, _D, _M, _RF, Enc, _Str) when is_atom(Atom) ->
+ write_atom(Atom, Enc);
print(Term, Col, Ll, D, M0, RecDefFun, Enc, Str) when is_tuple(Term);
is_list(Term);
is_map(Term);
is_bitstring(Term) ->
+ %% preprocess and compute total number of chars
If = {_S, Len} = print_length(Term, D, RecDefFun, Enc, Str),
+ %% use Len as CHAR_MAX if M0 = -1
M = max_cs(M0, Len),
if
Len < Ll - Col, Len =< M ->
+ %% write the whole thing on a single line when there is room
write(If);
true ->
+ %% compute the indentation TInd for tagged tuples and records
TInd = while_fail([-1, 4],
fun(I) -> cind(If, Col, Ll, M, I, 0, 0) end,
1),
pp(If, Col, Ll, M, TInd, indent(Col), 0, 0)
end;
print(Term, _Col, _Ll, _D, _M, _RF, _Enc, _Str) ->
+ %% atomic data types (bignums, atoms, ...) are never truncated
io_lib:write(Term).
%%%
%%% Local functions
%%%
+%% use M only if nonnegative, otherwise use Len as default value
max_cs(M, Len) when M < 0 ->
Len;
max_cs(M, _Len) ->
@@ -156,6 +169,7 @@ pp({S, _Len}, _Col, _Ll, _M, _TInd, _Ind, _LD, _W) ->
%% Print a tagged tuple by indenting the rest of the elements
%% differently to the tag. Tuple has size >= 2.
pp_tag_tuple([{Tag,Tlen} | L], Col, Ll, M, TInd, Ind, LD, W) ->
+ %% this uses TInd
TagInd = Tlen + 2,
Tcol = Col + TagInd,
S = $,,
@@ -254,6 +268,7 @@ pp_field({{field, Name, NameL, F}, _Len}, Col0, Ll, M, TInd, Ind0, LD, W0) ->
{[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;
@@ -332,6 +347,7 @@ pp_binary(S, N, _N0, Ind) ->
S
end.
+%% write the whole thing on a single line
write({{tuple, _IsTagged, L}, _}) ->
[${, write_list(L, $,), $}];
write({{list, L}, _}) ->
@@ -393,9 +409,14 @@ print_length({}, _D, _RF, _Enc, _Str) ->
{"{}", 2};
print_length(#{}=M, _D, _RF, _Enc, _Str) when map_size(M) =:= 0 ->
{"#{}", 3};
+print_length(Atom, _D, _RF, Enc, _Str) when is_atom(Atom) ->
+ S = write_atom(Atom, Enc),
+ {S, lists:flatlength(S)};
print_length(List, D, RF, Enc, Str) when is_list(List) ->
+ %% only flat lists are "printable"
case Str andalso printable_list(List, D, Enc) of
true ->
+ %% print as string, escaping double-quotes in the list
S = write_string(List, Enc),
{S, length(S)};
%% Truncated lists could break some existing code.
@@ -451,24 +472,15 @@ print_length(<<_/bitstring>>=Bin, D, _RF, Enc, Str) ->
end;
print_length(Term, _D, _RF, _Enc, _Str) ->
S = io_lib:write(Term),
- {S, lists:flatlength(S)}.
+ %% S can contain unicode, so iolist_size(S) cannot be used here
+ {S, string:length(S)}.
print_length_map(_Map, 1, _RF, _Enc, _Str) ->
{"#{...}", 6};
print_length_map(Map, D, RF, Enc, Str) when is_map(Map) ->
- Pairs = print_length_map_pairs(maps_to_list(Map, D), D, RF, Enc, Str),
+ Pairs = print_length_map_pairs(erts_internal:maps_to_list(Map, D), D, RF, Enc, Str),
{{map, Pairs}, list_length(Pairs, 3)}.
-maps_to_list(Map, D) when D < 0; map_size(Map) =< D ->
- maps:to_list(Map);
-maps_to_list(Map, D) ->
- F = fun(_K, _V, {N, L}) when N =:= D ->
- throw(L);
- (K, V, {N, L}) ->
- {N+1, [{K, V} | L]}
- end,
- lists:reverse(catch maps:fold(F, {0, []}, Map)).
-
print_length_map_pairs([], _D, _RF, _Enc, _Str) ->
[];
print_length_map_pairs(_Pairs, 1, _RF, _Enc, _Str) ->
@@ -493,7 +505,7 @@ print_length_tuple(Tuple, D, RF, Enc, Str) ->
print_length_record(_Tuple, 1, _RF, _RDefs, _Enc, _Str) ->
{"{...}", 5};
print_length_record(Tuple, D, RF, RDefs, Enc, Str) ->
- Name = [$# | io_lib:write_atom(element(1, Tuple))],
+ Name = [$# | write_atom(element(1, Tuple), Enc)],
NameL = length(Name),
Elements = tl(tuple_to_list(Tuple)),
L = print_length_fields(RDefs, D - 1, Elements, RF, Enc, Str),
@@ -508,7 +520,7 @@ print_length_fields([Def | Defs], D, [E | Es], RF, Enc, Str) ->
print_length_fields(Defs, D - 1, Es, RF, Enc, Str)].
print_length_field(Def, D, E, RF, Enc, Str) ->
- Name = io_lib:write_atom(Def),
+ Name = write_atom(Def, Enc),
{S, L} = print_length(E, D, RF, Enc, Str),
NameL = length(Name) + 3,
{{field, Name, NameL, {S, L}}, NameL + L}.
@@ -544,6 +556,7 @@ list_length_tail({_, Len}, Acc) ->
%% ?CHARS printable characters has depth 1.
-define(CHARS, 4).
+%% only flat lists are "printable"
printable_list(_L, 1, _Enc) ->
false;
printable_list(L, _D, latin1) ->
@@ -656,6 +669,11 @@ printable_char(C,unicode) ->
C > 16#DFFF andalso C < 16#FFFE orelse
C > 16#FFFF andalso C =< 16#10FFFF.
+write_atom(A, latin1) ->
+ io_lib:write_atom_as_latin1(A);
+write_atom(A, _Uni) ->
+ io_lib:write_atom(A).
+
write_string(S, latin1) ->
io_lib:write_latin1_string(S, $"); %"
write_string(S, _Uni) ->
@@ -841,9 +859,11 @@ while_fail([], _F, V) ->
while_fail([A | As], F, V) ->
try F(A) catch _ -> while_fail(As, F, V) end.
+%% make a string of N spaces
indent(N) when is_integer(N), N > 0 ->
chars($\s, N-1).
+%% prepend N spaces onto Ind
indent(1, Ind) -> % Optimization of common case
[$\s | Ind];
indent(4, Ind) -> % Optimization of common case
diff --git a/lib/stdlib/src/lib.erl b/lib/stdlib/src/lib.erl
index 56654097d9..c6eb0d7915 100644
--- a/lib/stdlib/src/lib.erl
+++ b/lib/stdlib/src/lib.erl
@@ -1,7 +1,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 1996-2016. 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,9 +22,12 @@
-export([flush_receive/0, error_message/2, progname/0, nonl/1, send/2,
sendw/2, eval_str/1]).
+-export([extended_parse_exprs/1, extended_parse_term/1,
+ subst_values_for_vars/2]).
+
-export([format_exception/6, format_exception/7,
format_stacktrace/4, format_stacktrace/5,
- format_call/4, format_call/5, format_fun/1]).
+ format_call/4, format_call/5, format_fun/1, format_fun/2]).
-spec flush_receive() -> 'ok'.
@@ -127,6 +130,224 @@ all_white([$\t|T]) -> all_white(T);
all_white([]) -> true;
all_white(_) -> false.
+%% `Tokens' is assumed to have been scanned with the 'text' option.
+%% The annotations of the returned expressions are locations.
+%%
+%% Can handle pids, ports, references, and external funs ("items").
+%% Known items are represented by variables in the erl_parse tree, and
+%% the items themselves are stored in the returned bindings.
+
+-spec extended_parse_exprs(Tokens) ->
+ {'ok', ExprList, Bindings} | {'error', ErrorInfo} when
+ Tokens :: [erl_scan:token()],
+ ExprList :: [erl_parse:abstract_expr()],
+ Bindings :: erl_eval:binding_struct(),
+ ErrorInfo :: erl_parse:error_info().
+
+extended_parse_exprs(Tokens) ->
+ Ts = tokens_fixup(Tokens),
+ case erl_parse:parse_exprs(Ts) of
+ {ok, Exprs0} ->
+ {Exprs, Bs} = expr_fixup(Exprs0),
+ {ok, reset_expr_anno(Exprs), Bs};
+ _ErrorInfo ->
+ erl_parse:parse_exprs(reset_token_anno(Ts))
+ end.
+
+tokens_fixup([]) -> [];
+tokens_fixup([T|Ts]=Ts0) ->
+ try token_fixup(Ts0) of
+ {NewT, NewTs} ->
+ [NewT|tokens_fixup(NewTs)]
+ catch
+ _:_ ->
+ [T|tokens_fixup(Ts)]
+ end.
+
+token_fixup(Ts) ->
+ {AnnoL, NewTs, FixupTag} = unscannable(Ts),
+ String = lists:append([erl_anno:text(A) || A <- AnnoL]),
+ _ = (fixup_fun(FixupTag))(String),
+ NewAnno = erl_anno:set_text(fixup_text(FixupTag), hd(AnnoL)),
+ {{string, NewAnno, String}, NewTs}.
+
+unscannable([{'#', A1}, {var, A2, 'Fun'}, {'<', A3}, {atom, A4, _},
+ {'.', A5}, {float, A6, _}, {'>', A7}|Ts]) ->
+ {[A1, A2, A3, A4, A5, A6, A7], Ts, function};
+unscannable([{'#', A1}, {var, A2, 'Fun'}, {'<', A3}, {atom, A4, _},
+ {'.', A5}, {atom, A6, _}, {'.', A7}, {integer, A8, _},
+ {'>', A9}|Ts]) ->
+ {[A1, A2, A3, A4, A5, A6, A7, A8, A9], Ts, function};
+unscannable([{'<', A1}, {float, A2, _}, {'.', A3}, {integer, A4, _},
+ {'>', A5}|Ts]) ->
+ {[A1, A2, A3, A4, A5], Ts, pid};
+unscannable([{'#', A1}, {var, A2, 'Port'}, {'<', A3}, {float, A4, _},
+ {'>', A5}|Ts]) ->
+ {[A1, A2, A3, A4, A5], Ts, port};
+unscannable([{'#', A1}, {var, A2, 'Ref'}, {'<', A3}, {float, A4, _},
+ {'.', A5}, {float, A6, _}, {'>', A7}|Ts]) ->
+ {[A1, A2, A3, A4, A5, A6, A7], Ts, reference}.
+
+expr_fixup(Expr0) ->
+ {Expr, Bs, _} = expr_fixup(Expr0, erl_eval:new_bindings(), 1),
+ {Expr, Bs}.
+
+expr_fixup({string,A,S}=T, Bs0, I) ->
+ try string_fixup(A, S) of
+ Value ->
+ Var = new_var(I),
+ Bs = erl_eval:add_binding(Var, Value, Bs0),
+ {{var, A, Var}, Bs, I+1}
+ catch
+ _:_ ->
+ {T, Bs0, I}
+ end;
+expr_fixup(Tuple, Bs0, I0) when is_tuple(Tuple) ->
+ {L, Bs, I} = expr_fixup(tuple_to_list(Tuple), Bs0, I0),
+ {list_to_tuple(L), Bs, I};
+expr_fixup([E0|Es0], Bs0, I0) ->
+ {E, Bs1, I1} = expr_fixup(E0, Bs0, I0),
+ {Es, Bs, I} = expr_fixup(Es0, Bs1, I1),
+ {[E|Es], Bs, I};
+expr_fixup(T, Bs, I) ->
+ {T, Bs, I}.
+
+string_fixup(A, S) ->
+ Text = erl_anno:text(A),
+ FixupTag = fixup_tag(Text, S),
+ (fixup_fun(FixupTag))(S).
+
+new_var(I) ->
+ list_to_atom(lists:concat(['__ExtendedParseExprs_', I, '__'])).
+
+reset_token_anno(Tokens) ->
+ [setelement(2, T, (reset_anno())(element(2, T))) || T <- Tokens].
+
+reset_expr_anno(Exprs) ->
+ [erl_parse:map_anno(reset_anno(), E) || E <- Exprs].
+
+reset_anno() ->
+ fun(A) -> erl_anno:new(erl_anno:location(A)) end.
+
+fixup_fun(function) -> fun function/1;
+fixup_fun(pid) -> fun erlang:list_to_pid/1;
+fixup_fun(port) -> fun erlang:list_to_port/1;
+fixup_fun(reference) -> fun erlang:list_to_ref/1.
+
+function(S) ->
+ %% External function.
+ {ok, [_, _, _,
+ {atom, _, Module}, _,
+ {atom, _, Function}, _,
+ {integer, _, Arity}|_], _} = erl_scan:string(S),
+ erlang:make_fun(Module, Function, Arity).
+
+fixup_text(function) -> "function";
+fixup_text(pid) -> "pid";
+fixup_text(port) -> "port";
+fixup_text(reference) -> "reference".
+
+fixup_tag("function", "#"++_) -> function;
+fixup_tag("pid", "<"++_) -> pid;
+fixup_tag("port", "#"++_) -> port;
+fixup_tag("reference", "#"++_) -> reference.
+
+%%% End of extended_parse_exprs.
+
+%% `Tokens' is assumed to have been scanned with the 'text' option.
+%%
+%% Can handle pids, ports, references, and external funs.
+
+-spec extended_parse_term(Tokens) ->
+ {'ok', Term} | {'error', ErrorInfo} when
+ Tokens :: [erl_scan:token()],
+ Term :: term(),
+ ErrorInfo :: erl_parse:error_info().
+
+extended_parse_term(Tokens) ->
+ case extended_parse_exprs(Tokens) of
+ {ok, [Expr], Bindings} ->
+ try normalise(Expr, Bindings) of
+ Term ->
+ {ok, Term}
+ catch
+ _:_ ->
+ Loc = erl_anno:location(element(2, Expr)),
+ {error,{Loc,?MODULE,"bad term"}}
+ end;
+ {ok, [_,Expr|_], _Bindings} ->
+ Loc = erl_anno:location(element(2, Expr)),
+ {error,{Loc,?MODULE,"bad term"}};
+ {error, _} = Error ->
+ Error
+ end.
+
+%% From erl_parse.
+normalise({var, _, V}, Bs) ->
+ {value, Value} = erl_eval:binding(V, Bs),
+ Value;
+normalise({char,_,C}, _Bs) -> C;
+normalise({integer,_,I}, _Bs) -> I;
+normalise({float,_,F}, _Bs) -> F;
+normalise({atom,_,A}, _Bs) -> A;
+normalise({string,_,S}, _Bs) -> S;
+normalise({nil,_}, _Bs) -> [];
+normalise({bin,_,Fs}, Bs) ->
+ {value, B, _} =
+ eval_bits:expr_grp(Fs, [],
+ fun(E, _) ->
+ {value, normalise(E, Bs), []}
+ end, [], true),
+ B;
+normalise({cons,_,Head,Tail}, Bs) ->
+ [normalise(Head, Bs)|normalise(Tail, Bs)];
+normalise({tuple,_,Args}, Bs) ->
+ list_to_tuple(normalise_list(Args, Bs));
+normalise({map,_,Pairs}, Bs) ->
+ maps:from_list(lists:map(fun
+ %% only allow '=>'
+ ({map_field_assoc,_,K,V}) ->
+ {normalise(K, Bs),normalise(V, Bs)}
+ end, Pairs));
+%% Special case for unary +/-.
+normalise({op,_,'+',{char,_,I}}, _Bs) -> I;
+normalise({op,_,'+',{integer,_,I}}, _Bs) -> I;
+normalise({op,_,'+',{float,_,F}}, _Bs) -> F;
+normalise({op,_,'-',{char,_,I}}, _Bs) -> -I; %Weird, but compatible!
+normalise({op,_,'-',{integer,_,I}}, _Bs) -> -I;
+normalise({op,_,'-',{float,_,F}}, _Bs) -> -F;
+normalise({'fun',_,{function,{atom,_,M},{atom,_,F},{integer,_,A}}}, _Bs) ->
+ %% Since "#Fun<M.F.A>" is recognized, "fun M:F/A" should be too.
+ fun M:F/A.
+
+normalise_list([H|T], Bs) ->
+ [normalise(H, Bs)|normalise_list(T, Bs)];
+normalise_list([], _Bs) ->
+ [].
+
+%% To be used on ExprList and Bindings returned from extended_parse_exprs().
+%% Substitute {value, A, Item} for {var, A, ExtendedParseVar}.
+%% {value, A, Item} is a shell/erl_eval convention, and for example
+%% the linter cannot handle it.
+
+-spec subst_values_for_vars(ExprList, Bindings) -> [term()] when
+ ExprList :: [erl_parse:abstract_expr()],
+ Bindings :: erl_eval:binding_struct().
+
+subst_values_for_vars({var, A, V}=Var, Bs) ->
+ case erl_eval:binding(V, Bs) of
+ {value, Value} ->
+ {value, A, Value};
+ unbound ->
+ Var
+ end;
+subst_values_for_vars(L, Bs) when is_list(L) ->
+ [subst_values_for_vars(E, Bs) || E <- L];
+subst_values_for_vars(T, Bs) when is_tuple(T) ->
+ list_to_tuple(subst_values_for_vars(tuple_to_list(T), Bs));
+subst_values_for_vars(T, _Bs) ->
+ T.
+
%%% Formatting of exceptions, mfa:s and funs.
%% -> iolist() (no \n at end)
@@ -179,7 +400,11 @@ format_call(I, ForMForFun, As, FormatFun, Enc)
format_call("", n_spaces(I-1), ForMForFun, As, FormatFun, Enc).
%% -> iolist() (no \n at end)
-format_fun(Fun) when is_function(Fun) ->
+format_fun(Fun) ->
+ format_fun(Fun, latin1).
+
+%% -> iolist() (no \n at end)
+format_fun(Fun, Enc) when is_function(Fun) ->
{module, M} = erlang:fun_info(Fun, module),
{name, F} = erlang:fun_info(Fun, name),
{arity, A} = erlang:fun_info(Fun, arity),
@@ -189,9 +414,9 @@ format_fun(Fun) when is_function(Fun) ->
{type, local} when M =:= erl_eval ->
io_lib:fwrite(<<"interpreted function with arity ~w">>, [A]);
{type, local} ->
- mfa_to_string(M, F, A);
+ mfa_to_string(M, F, A, Enc);
{type, external} ->
- mfa_to_string(M, F, A)
+ mfa_to_string(M, F, A, Enc)
end.
analyze_exception(error, Term, Stack) ->
@@ -233,11 +458,11 @@ explain_reason({badarg,V}, error=Cl, [], PF, S, _Enc) -> % orelse, andalso
format_value(V, <<"bad argument: ">>, Cl, PF, S);
explain_reason(badarith, error, [], _PF, _S, _Enc) ->
<<"an error occurred when evaluating an arithmetic expression">>;
-explain_reason({badarity,{Fun,As}}, error, [], _PF, _S, _Enc)
+explain_reason({badarity,{Fun,As}}, error, [], _PF, _S, Enc)
when is_function(Fun) ->
%% Only the arity is displayed, not the arguments As.
- io_lib:fwrite(<<"~s called with ~s">>,
- [format_fun(Fun), argss(length(As))]);
+ io_lib:fwrite(<<"~ts called with ~s">>,
+ [format_fun(Fun, Enc), argss(length(As))]);
explain_reason({badfun,Term}, error=Cl, [], PF, S, _Enc) ->
format_value(Term, <<"bad function ">>, Cl, PF, S);
explain_reason({badmatch,Term}, error=Cl, [], PF, S, _Enc) ->
@@ -268,14 +493,15 @@ explain_reason({try_clause,V}, error=Cl, [], PF, S, _Enc) ->
%% "there is no try clause with a true guard sequence and a
%% pattern matching..."
format_value(V, <<"no try clause matching ">>, Cl, PF, S);
-explain_reason(undef, error, [{M,F,A,_}], _PF, _S, _Enc) ->
+explain_reason(undef, error, [{M,F,A,_}], _PF, _S, Enc) ->
%% Only the arity is displayed, not the arguments, if there are any.
- io_lib:fwrite(<<"undefined function ~s">>,
- [mfa_to_string(M, F, n_args(A))]);
-explain_reason({shell_undef,F,A,_}, error, [], _PF, _S, _Enc) ->
+ io_lib:fwrite(<<"undefined function ~ts">>,
+ [mfa_to_string(M, F, n_args(A), Enc)]);
+explain_reason({shell_undef,F,A,_}, error, [], _PF, _S, Enc) ->
%% Give nicer reports for undefined shell functions
%% (but not when the user actively calls shell_default:F(...)).
- io_lib:fwrite(<<"undefined shell command ~s/~w">>, [F, n_args(A)]);
+ FS = to_string(F, Enc),
+ io_lib:fwrite(<<"undefined shell command ~ts/~w">>, [FS, n_args(A)]);
%% Exit codes returned by erl_eval only:
explain_reason({argument_limit,_Fun}, error, [], _PF, _S, _Enc) ->
io_lib:fwrite(<<"limit of number of arguments to interpreted function"
@@ -325,17 +551,18 @@ format_stacktrace1(S0, Stack0, PF, SF, Enc) ->
format_stacktrace2(S, Stack, 1, PF, Enc).
format_stacktrace2(S, [{M,F,A,L}|Fs], N, PF, Enc) when is_integer(A) ->
- [io_lib:fwrite(<<"~s~s ~s ~s">>,
+ [io_lib:fwrite(<<"~s~s ~ts ~s">>,
[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) ->
@@ -373,10 +600,10 @@ format_call(ErrStr, Pre1, ForMForFun, As, PF, Enc) ->
{yes,Op} ->
format_op(ErrStr, Pre1, Op, As, PF, Enc);
no ->
- MFs = mf_to_string(ForMForFun, Arity),
- I1 = iolist_size([Pre1,ErrStr|MFs]),
+ MFs = mf_to_string(ForMForFun, Arity, Enc),
+ I1 = string:length([Pre1,ErrStr|MFs]),
S1 = pp_arguments(PF, As, I1, Enc),
- S2 = pp_arguments(PF, As, iolist_size([Pre1|MFs]), Enc),
+ S2 = pp_arguments(PF, As, string:length([Pre1|MFs]), Enc),
Long = count_nl(pp_arguments(PF, [a2345,b2345], I1, Enc)) > 0,
case Long or (count_nl(S2) < count_nl(S1)) of
true ->
@@ -435,10 +662,10 @@ printable_list(latin1, As) ->
printable_list(_, As) ->
io_lib:printable_list(As).
-mfa_to_string(M, F, A) ->
- io_lib:fwrite(<<"~s/~w">>, [mf_to_string({M, F}, A), A]).
+mfa_to_string(M, F, A, Enc) ->
+ io_lib:fwrite(<<"~ts/~w">>, [mf_to_string({M, F}, A, Enc), A]).
-mf_to_string({M, F}, A) ->
+mf_to_string({M, F}, A, Enc) ->
case erl_internal:bif(M, F, A) of
true ->
io_lib:fwrite(<<"~w">>, [F]);
@@ -449,13 +676,15 @@ mf_to_string({M, F}, A) ->
{yes, F} ->
atom_to_list(F);
no ->
- io_lib:fwrite(<<"~w:~w">>, [M, F])
+ FS = to_string(F, Enc),
+ io_lib:fwrite(<<"~w:~ts">>, [M, FS])
end
end;
-mf_to_string(Fun, _A) when is_function(Fun) ->
- format_fun(Fun);
-mf_to_string(F, _A) ->
- io_lib:fwrite(<<"~w">>, [F]).
+mf_to_string(Fun, _A, Enc) when is_function(Fun) ->
+ format_fun(Fun, Enc);
+mf_to_string(F, _A, Enc) ->
+ FS = to_string(F, Enc),
+ io_lib:fwrite(<<"~ts">>, [FS]).
format_value(V, ErrStr, Class, PF, S) ->
Pre1Sz = exited_size(Class),
@@ -504,9 +733,14 @@ exited(exit) ->
exited(throw) ->
<<"exception throw: ">>.
+to_string(A, latin1) ->
+ io_lib:write_atom_as_latin1(A);
+to_string(A, _) ->
+ io_lib:write_atom(A).
+
size(latin1, S) ->
{iolist_size(S),S};
size(_, S0) ->
S = unicode:characters_to_list(S0, unicode),
true = is_list(S),
- {length(S),S}.
+ {string:length(S),S}.
diff --git a/lib/stdlib/src/math.erl b/lib/stdlib/src/math.erl
index 97c965e27a..3a3b384d8f 100644
--- a/lib/stdlib/src/math.erl
+++ b/lib/stdlib/src/math.erl
@@ -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 98745b13f3..6616e957c0 100644
--- a/lib/stdlib/src/ms_transform.erl
+++ b/lib/stdlib/src/ms_transform.erl
@@ -1,7 +1,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 2002-2016. All Rights Reserved.
+%% Copyright Ericsson AB 2002-2017. All Rights Reserved.
%%
%% Licensed under the Apache License, Version 2.0 (the "License");
%% you may not use this file except in compliance with the License.
@@ -91,12 +91,12 @@ format_error(?ERR_GUARDMATCH) ->
"fun with guard matching ('=' in guard) is illegal as match_spec as well";
format_error({?ERR_GUARDLOCALCALL, Name, Arithy}) ->
lists:flatten(io_lib:format("fun containing the local function call "
- "'~w/~w' (called in guard) "
+ "'~tw/~w' (called in guard) "
"cannot be translated into match_spec",
[Name, Arithy]));
format_error({?ERR_GUARDREMOTECALL, Module, Name, Arithy}) ->
lists:flatten(io_lib:format("fun containing the remote function call "
- "'~w:~w/~w' (called in guard) "
+ "'~w:~tw/~w' (called in guard) "
"cannot be translated into match_spec",
[Module,Name,Arithy]));
format_error({?ERR_GUARDELEMENT, Str}) ->
@@ -117,12 +117,12 @@ format_error(?ERR_BODYMATCH) ->
"fun with body matching ('=' in body) is illegal as match_spec";
format_error({?ERR_BODYLOCALCALL, Name, Arithy}) ->
lists:flatten(io_lib:format("fun containing the local function "
- "call '~w/~w' (called in body) "
+ "call '~tw/~w' (called in body) "
"cannot be translated into match_spec",
[Name,Arithy]));
format_error({?ERR_BODYREMOTECALL, Module, Name, Arithy}) ->
lists:flatten(io_lib:format("fun containing the remote function call "
- "'~w:~w/~w' (called in body) "
+ "'~w:~tw/~w' (called in body) "
"cannot be translated into match_spec",
[Module,Name,Arithy]));
format_error({?ERR_BODYELEMENT, Str}) ->
@@ -147,15 +147,15 @@ format_error({?ERR_UNBOUND_VARIABLE, Str}) ->
"into match_spec", [Str]));
format_error({?ERR_HEADBADREC,Name}) ->
lists:flatten(
- io_lib:format("fun head contains unknown record type ~w",[Name]));
+ io_lib:format("fun head contains unknown record type ~tw",[Name]));
format_error({?ERR_HEADBADFIELD,RName,FName}) ->
lists:flatten(
- io_lib:format("fun head contains reference to unknown field ~w in "
- "record type ~w",[FName, RName]));
+ io_lib:format("fun head contains reference to unknown field ~tw in "
+ "record type ~tw",[FName, RName]));
format_error({?ERR_HEADMULTIFIELD,RName,FName}) ->
lists:flatten(
- io_lib:format("fun head contains already defined field ~w in "
- "record type ~w",[FName, RName]));
+ io_lib:format("fun head contains already defined field ~tw in "
+ "record type ~tw",[FName, RName]));
format_error({?ERR_HEADDOLLARATOM,Atom}) ->
lists:flatten(
io_lib:format("fun head contains atom ~w, which conflics with reserved "
@@ -166,28 +166,28 @@ format_error({?ERR_HEADBINMATCH,Atom}) ->
"which cannot be translated into match_spec", [Atom]));
format_error({?ERR_GUARDBADREC,Name}) ->
lists:flatten(
- io_lib:format("fun guard contains unknown record type ~w",[Name]));
+ io_lib:format("fun guard contains unknown record type ~tw",[Name]));
format_error({?ERR_GUARDBADFIELD,RName,FName}) ->
lists:flatten(
- io_lib:format("fun guard contains reference to unknown field ~w in "
- "record type ~w",[FName, RName]));
+ io_lib:format("fun guard contains reference to unknown field ~tw in "
+ "record type ~tw",[FName, RName]));
format_error({?ERR_GUARDMULTIFIELD,RName,FName}) ->
lists:flatten(
- io_lib:format("fun guard contains already defined field ~w in "
- "record type ~w",[FName, RName]));
+ io_lib:format("fun guard contains already defined field ~tw in "
+ "record type ~tw",[FName, RName]));
format_error({?ERR_BODYBADREC,Name}) ->
lists:flatten(
- io_lib:format("fun body contains unknown record type ~w",[Name]));
+ io_lib:format("fun body contains unknown record type ~tw",[Name]));
format_error({?ERR_BODYBADFIELD,RName,FName}) ->
lists:flatten(
- io_lib:format("fun body contains reference to unknown field ~w in "
- "record type ~w",[FName, RName]));
+ io_lib:format("fun body contains reference to unknown field ~tw in "
+ "record type ~tw",[FName, RName]));
format_error({?ERR_BODYMULTIFIELD,RName,FName}) ->
lists:flatten(
- io_lib:format("fun body contains already defined field ~w in "
- "record type ~w",[FName, RName]));
+ io_lib:format("fun body contains already defined field ~tw in "
+ "record type ~tw",[FName, RName]));
format_error(Else) ->
- lists:flatten(io_lib:format("Unknown error code ~w",[Else])).
+ lists:flatten(io_lib:format("Unknown error code ~tw",[Else])).
%%
%% Called when translating in shell
@@ -501,10 +501,20 @@ tg0(Line,[H|T],B) ->
tg({match,Line,_,_},B) ->
throw({error,Line,?ERR_GENMATCH+B#tgd.eb});
-tg({op, Line, Operator, O1, O2}, B) ->
- {tuple, Line, [{atom, Line, Operator}, tg(O1,B), tg(O2,B)]};
-tg({op, Line, Operator, O1}, B) ->
- {tuple, Line, [{atom, Line, Operator}, tg(O1,B)]};
+tg({op, Line, Operator, O1, O2}=Expr, B) ->
+ case erl_eval:partial_eval(Expr) of
+ Expr ->
+ {tuple, Line, [{atom, Line, Operator}, tg(O1, B), tg(O2, B)]};
+ Value ->
+ Value
+ end;
+tg({op, Line, Operator, O1}=Expr, B) ->
+ case erl_eval:partial_eval(Expr) of
+ Expr ->
+ {tuple, Line, [{atom, Line, Operator}, tg(O1, B)]};
+ Value ->
+ Value
+ end;
tg({call, _Line, {atom, Line2, bindings},[]},_B) ->
{atom, Line2, '$*'};
tg({call, _Line, {atom, Line2, object},[]},_B) ->
@@ -723,7 +733,7 @@ tg(T,B) when is_tuple(T), tuple_size(T) >= 2 ->
throw({error,Line,{?ERR_GENELEMENT+B#tgd.eb,
translate_language_element(Element)}});
tg(Other,B) ->
- Element = io_lib:format("unknown element ~w", [Other]),
+ Element = io_lib:format("unknown element ~tw", [Other]),
throw({error,unknown,{?ERR_GENELEMENT+B#tgd.eb,Element}}).
transform_head([V],OuterBound) ->
diff --git a/lib/stdlib/src/orddict.erl b/lib/stdlib/src/orddict.erl
index 37cf0084f0..9a2772949b 100644
--- a/lib/stdlib/src/orddict.erl
+++ b/lib/stdlib/src/orddict.erl
@@ -1,7 +1,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 1996-2015. All Rights Reserved.
+%% Copyright Ericsson AB 1996-2017. All Rights Reserved.
%%
%% Licensed under the Apache License, Version 2.0 (the "License");
%% you may not use this file except in compliance with the License.
@@ -22,7 +22,7 @@
%% Standard interface.
-export([new/0,is_key/2,to_list/1,from_list/1,size/1,is_empty/1]).
--export([fetch/2,find/2,fetch_keys/1,erase/2]).
+-export([fetch/2,find/2,fetch_keys/1,erase/2,take/2]).
-export([store/3,append/3,append_list/3,update/3,update/4,update_counter/3]).
-export([fold/3,map/2,filter/2,merge/3]).
@@ -106,6 +106,23 @@ erase(Key, [{K,_}=E|Dict]) when Key > K ->
erase(_Key, [{_K,_Val}|Dict]) -> Dict; %Key == K
erase(_, []) -> [].
+-spec take(Key, Orddict) -> {Value, Orddict1} | error when
+ Orddict :: orddict(Key, Value),
+ Orddict1 :: orddict(Key, Value),
+ Key :: term(),
+ Value :: term().
+
+take(Key, Dict) ->
+ take_1(Key, Dict, []).
+
+take_1(Key, [{K,_}|_], _Acc) when Key < K ->
+ error;
+take_1(Key, [{K,_}=P|D], Acc) when Key > K ->
+ take_1(Key, D, [P|Acc]);
+take_1(_Key, [{_K,Value}|D], Acc) ->
+ {Value,lists:reverse(Acc, D)};
+take_1(_, [], _) -> error.
+
-spec store(Key, Value, Orddict1) -> Orddict2 when
Orddict1 :: orddict(Key, Value),
Orddict2 :: orddict(Key, Value).
diff --git a/lib/stdlib/src/otp_internal.erl b/lib/stdlib/src/otp_internal.erl
index 3bd338071b..c59db903dc 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-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.
@@ -47,9 +47,6 @@ obsolete(Module, Name, Arity) ->
obsolete_1(net, _, _) ->
{deprecated, "module 'net' obsolete; use 'net_adm'"};
-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\" "
@@ -58,186 +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}};
+%% *** 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 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) ->
- {deprecated, {crypto, strong_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 ***
@@ -390,13 +441,13 @@ obsolete_1(erlang, concat_binary, 1) ->
%% 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, _, _) ->
@@ -408,7 +459,7 @@ 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, _, _) ->
@@ -416,12 +467,12 @@ obsolete_1(inviso, _, _) ->
%% 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"};
+ {removed,"the gs application has been removed; 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?
@@ -434,10 +485,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) ->
@@ -463,21 +510,23 @@ 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) ->
@@ -516,10 +565,9 @@ obsolete_1(erl_parse, get_attribute, 2) ->
obsolete_1(erl_lint, modify_line, 2) ->
{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"};
@@ -549,7 +597,21 @@ obsolete_1(queue, lait, 1) ->
obsolete_1(overload, _, _) ->
{removed, "removed in OTP 19"};
obsolete_1(rpc, safe_multi_server_call, A) when A =:= 2; A =:= 3 ->
- {removed, {rpc, multi_server_call, A}};
+ {removed, {rpc, multi_server_call, A}, "removed in OTP 19"};
+
+%% Added in OTP 20.
+
+obsolete_1(filename, find_src, 1) ->
+ {deprecated, "deprecated; use filelib:find_source/1 instead"};
+obsolete_1(filename, find_src, 2) ->
+ {deprecated, "deprecated; use filelib:find_source/3 instead"};
+
+%% Removed in OTP 20.
+
+obsolete_1(erlang, hash, 2) ->
+ {removed, {erlang, phash2, 2}, "20.0"};
+
+%% not obsolete
obsolete_1(_, _, _) ->
no.
diff --git a/lib/stdlib/src/proc_lib.erl b/lib/stdlib/src/proc_lib.erl
index 3dc1848550..d4d1bdccec 100644
--- a/lib/stdlib/src/proc_lib.erl
+++ b/lib/stdlib/src/proc_lib.erl
@@ -1,7 +1,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 1996-2016. 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.
@@ -232,7 +232,7 @@ init_p(Parent, Ancestors, Fun) when is_function(Fun) ->
Fun()
catch
Class:Reason ->
- exit_p(Class, Reason)
+ exit_p(Class, Reason, erlang:get_stacktrace())
end.
-spec init_p(pid(), [pid()], atom(), atom(), [term()]) -> term().
@@ -247,7 +247,7 @@ init_p_do_apply(M, F, A) ->
apply(M, F, A)
catch
Class:Reason ->
- exit_p(Class, Reason)
+ exit_p(Class, Reason, erlang:get_stacktrace())
end.
-spec wake_up(atom(), atom(), [term()]) -> term().
@@ -257,22 +257,29 @@ wake_up(M, F, A) when is_atom(M), is_atom(F), is_list(A) ->
apply(M, F, A)
catch
Class:Reason ->
- exit_p(Class, Reason)
+ exit_p(Class, Reason, erlang:get_stacktrace())
end.
-exit_p(Class, Reason) ->
+exit_p(Class, Reason, Stacktrace) ->
case get('$initial_call') of
{M,F,A} when is_atom(M), is_atom(F), is_integer(A) ->
MFA = {M,F,make_dummy_args(A, [])},
- crash_report(Class, Reason, MFA),
- exit(Reason);
+ crash_report(Class, Reason, MFA, Stacktrace),
+ erlang:raise(exit, exit_reason(Class, Reason, Stacktrace), Stacktrace);
_ ->
%% The process dictionary has been cleared or
%% possibly modified.
- crash_report(Class, Reason, []),
- exit(Reason)
+ crash_report(Class, Reason, [], Stacktrace),
+ erlang:raise(exit, exit_reason(Class, Reason, Stacktrace), Stacktrace)
end.
+exit_reason(error, Reason, Stacktrace) ->
+ {Reason, Stacktrace};
+exit_reason(exit, Reason, _Stacktrace) ->
+ Reason;
+exit_reason(throw, Reason, Stacktrace) ->
+ {{nocatch, Reason}, Stacktrace}.
+
-spec start(Module, Function, Args) -> Ret when
Module :: module(),
Function :: atom(),
@@ -492,26 +499,28 @@ trans_init(M, F, A) when is_atom(M), is_atom(F) ->
%% Generate a crash report.
%% -----------------------------------------------------
-crash_report(exit, normal, _) -> ok;
-crash_report(exit, shutdown, _) -> ok;
-crash_report(exit, {shutdown,_}, _) -> ok;
-crash_report(Class, Reason, StartF) ->
- OwnReport = my_info(Class, Reason, StartF),
+crash_report(exit, normal, _, _) -> ok;
+crash_report(exit, shutdown, _, _) -> ok;
+crash_report(exit, {shutdown,_}, _, _) -> ok;
+crash_report(Class, Reason, StartF, Stacktrace) ->
+ OwnReport = my_info(Class, Reason, StartF, Stacktrace),
LinkReport = linked_info(self()),
Rep = [OwnReport,LinkReport],
error_logger:error_report(crash_report, Rep).
-my_info(Class, Reason, []) ->
- my_info_1(Class, Reason);
-my_info(Class, Reason, StartF) ->
- [{initial_call, StartF}|my_info_1(Class, Reason)].
+my_info(Class, Reason, [], Stacktrace) ->
+ my_info_1(Class, Reason, Stacktrace);
+my_info(Class, Reason, StartF, Stacktrace) ->
+ [{initial_call, StartF}|
+ my_info_1(Class, Reason, Stacktrace)].
-my_info_1(Class, Reason) ->
+my_info_1(Class, Reason, Stacktrace) ->
[{pid, self()},
get_process_info(self(), registered_name),
- {error_info, {Class,Reason,erlang:get_stacktrace()}},
+ {error_info, {Class,Reason,Stacktrace}},
get_ancestors(self()),
- get_process_info(self(), messages),
+ get_process_info(self(), message_queue_len),
+ get_messages(self()),
get_process_info(self(), links),
get_cleaned_dictionary(self()),
get_process_info(self(), trap_exit),
@@ -531,12 +540,49 @@ get_ancestors(Pid) ->
{ancestors,[]}
end.
+%% The messages and the dictionary are possibly limited too much if
+%% some error handles output the messages or the dictionary using ~P
+%% or ~W with depth greater than the depth used here (the depth of
+%% control characters P and W takes precedence over the depth set by
+%% application variable error_logger_format_depth). However, it is
+%% assumed that all report handlers call proc_lib:format().
+get_messages(Pid) ->
+ Messages = get_process_messages(Pid),
+ {messages, error_logger:limit_term(Messages)}.
+
+get_process_messages(Pid) ->
+ Depth = error_logger:get_format_depth(),
+ case Pid =/= self() orelse Depth =:= unlimited of
+ true ->
+ {messages, Messages} = get_process_info(Pid, messages),
+ Messages;
+ false ->
+ %% If there are more messages than Depth, garbage
+ %% collection can sometimes be avoided by collecting just
+ %% enough messages for the crash report. It is assumed the
+ %% process is about to die anyway.
+ receive_messages(Depth)
+ end.
+
+receive_messages(0) -> [];
+receive_messages(N) ->
+ receive
+ M ->
+ [M|receive_messages(N - 1)]
+ after 0 ->
+ []
+ end.
+
get_cleaned_dictionary(Pid) ->
case get_process_info(Pid,dictionary) of
- {dictionary,Dict} -> {dictionary,clean_dict(Dict)};
+ {dictionary,Dict} -> {dictionary,cleaned_dict(Dict)};
_ -> {dictionary,[]}
end.
+cleaned_dict(Dict) ->
+ CleanDict = clean_dict(Dict),
+ error_logger:limit_term(CleanDict).
+
clean_dict([{'$ancestors',_}|Dict]) ->
clean_dict(Dict);
clean_dict([{'$initial_call',_}|Dict]) ->
@@ -574,20 +620,24 @@ make_neighbour_reports1([P|Ps]) ->
make_neighbour_reports1([]) ->
[].
+%% Do not include messages or process dictionary, even if
+%% error_logger_format_depth is unlimited.
make_neighbour_report(Pid) ->
[{pid, Pid},
get_process_info(Pid, registered_name),
get_initial_call(Pid),
get_process_info(Pid, current_function),
get_ancestors(Pid),
- get_process_info(Pid, messages),
+ get_process_info(Pid, message_queue_len),
+ %% get_messages(Pid),
get_process_info(Pid, links),
- get_cleaned_dictionary(Pid),
+ %% get_cleaned_dictionary(Pid),
get_process_info(Pid, trap_exit),
get_process_info(Pid, status),
get_process_info(Pid, heap_size),
get_process_info(Pid, stack_size),
- get_process_info(Pid, reductions)
+ get_process_info(Pid, reductions),
+ get_process_info(Pid, current_stacktrace)
].
get_initial_call(Pid) ->
@@ -714,24 +764,39 @@ format(CrashReport, Encoding) ->
format([OwnReport,LinkReport], Encoding, Depth) ->
Extra = {Encoding,Depth},
- OwnFormat = format_report(OwnReport, Extra),
- LinkFormat = format_report(LinkReport, Extra),
+ MyIndent = " ",
+ OwnFormat = format_report(OwnReport, MyIndent, Extra),
+ LinkFormat = format_link_report(LinkReport, MyIndent, Extra),
Str = io_lib:format(" crasher:~n~ts neighbours:~n~ts",
[OwnFormat, LinkFormat]),
lists:flatten(Str).
-format_report(Rep, 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], Indent, Extra) ->
+ Rep = case Link of
+ {neighbour,Rep0} -> Rep0;
+ _ -> Link
+ end,
+ LinkIndent = [" ",Indent],
+ [Indent,"neighbour:\n",format_report(Rep, LinkIndent, Extra)|
+ format_link_report(Reps, Indent, Extra)];
+format_link_report(Rep, Indent, Extra) ->
+ format_report(Rep, Indent, Extra).
+
+format_report(Rep, Indent, Extra) when is_list(Rep) ->
+ format_rep(Rep, Indent, Extra);
+format_report(Rep, Indent, {Enc,unlimited}) ->
+ io_lib:format("~s~"++modifier(Enc)++"p~n", [Indent, Rep]);
+format_report(Rep, Indent, {Enc,Depth}) ->
+ io_lib:format("~s~"++modifier(Enc)++"P~n", [Indent, Rep, Depth]).
+
+format_rep([{initial_call,InitialCall}|Rep], Indent, Extra) ->
+ [format_mfa(Indent, InitialCall, Extra)|format_rep(Rep, Indent, Extra)];
+format_rep([{error_info,{Class,Reason,StackTrace}}|Rep], Indent, Extra) ->
+ [format_exception(Class, Reason, StackTrace, Extra)|
+ format_rep(Rep, Indent, Extra)];
+format_rep([{Tag,Data}|Rep], Indent, Extra) ->
+ [format_tag(Indent, Tag, Data, Extra)|format_rep(Rep, Indent, Extra)];
+format_rep(_, _, _Extra) ->
[].
format_exception(Class, Reason, StackTrace, {Enc,_}=Extra) ->
@@ -742,16 +807,21 @@ format_exception(Class, Reason, StackTrace, {Enc,_}=Extra) ->
[EI, lib:format_exception(1+length(EI), Class, Reason,
StackTrace, StackFun, PF, Enc), "\n"].
-format_mfa({M,F,Args}=StartF, Depth) ->
+format_mfa(Indent, {M,F,Args}=StartF, {Enc,_}=Extra) ->
try
A = length(Args),
- [" initial call: ",atom_to_list(M),$:,atom_to_list(F),$/,
+ [Indent,"initial call: ",atom_to_list(M),$:,to_string(F, Enc),$/,
integer_to_list(A),"\n"]
catch
error:_ ->
- format_tag(initial_call, StartF, Depth)
+ format_tag(Indent, initial_call, StartF, Extra)
end.
+to_string(A, latin1) ->
+ io_lib:write_atom_as_latin1(A);
+to_string(A, _) ->
+ io_lib:write_atom(A).
+
pp_fun({Enc,Depth}) ->
{Letter,Tl} = case Depth of
unlimited -> {"p",[]};
@@ -762,12 +832,12 @@ pp_fun({Enc,Depth}) ->
io_lib:format("~." ++ integer_to_list(I) ++ P, [Term|Tl])
end.
-format_tag(Tag, Data, {_Enc,Depth}) ->
+format_tag(Indent, Tag, Data, {_Enc,Depth}) ->
case Depth of
unlimited ->
- io_lib:format(" ~p: ~80.18p~n", [Tag, Data]);
+ io_lib:format("~s~p: ~80.18p~n", [Indent, Tag, Data]);
_ ->
- io_lib:format(" ~p: ~80.18P~n", [Tag, Data, Depth])
+ io_lib:format("~s~p: ~80.18P~n", [Indent, Tag, Data, Depth])
end.
modifier(latin1) -> "";
diff --git a/lib/stdlib/src/proplists.erl b/lib/stdlib/src/proplists.erl
index 5356467b19..340dfdcac9 100644
--- a/lib/stdlib/src/proplists.erl
+++ b/lib/stdlib/src/proplists.erl
@@ -1,8 +1,3 @@
-%%
-%% %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
@@ -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
diff --git a/lib/stdlib/src/qlc.erl b/lib/stdlib/src/qlc.erl
index 8c4d835432..535ca57a6b 100644
--- a/lib/stdlib/src/qlc.erl
+++ b/lib/stdlib/src/qlc.erl
@@ -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 lib:extended_parse_exprs(Tokens) of
+ {ok, [Expr0], SBs} ->
+ {ok, Expr0, SBs};
+ {ok, _ExprList, _SBs} ->
+ erlang:error(badarg,
+ [Str, Options, Bindings]);
+ E ->
+ E
+ end,
+ case ScanRes of
+ {ok, Expr, XBs} ->
+ Bs1 = merge_binding_structs(Bindings, XBs),
+ case qlc_pt:transform_expression(Expr, Bs1) of
{ok, {call, _, _QlcQ, Handle}} ->
{value, QLC_lc, _} =
- erl_eval:exprs(Handle, Bindings),
+ erl_eval:exprs(Handle, Bs1),
O = #qlc_opt{unique = Unique,
cache = Cache,
max_lookup = MaxLookup,
@@ -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;
@@ -770,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
@@ -1180,9 +1193,12 @@ abstract1({table, {M, F, As0}}, _NElements, _Depth, Anno)
abstract1({table, TableDesc}, _NElements, _Depth, _A) ->
case io_lib:deep_char_list(TableDesc) of
true ->
- {ok, Tokens, _} = erl_scan:string(lists:flatten(TableDesc++".")),
- {ok, [Expr]} = erl_parse:parse_exprs(Tokens),
- Expr;
+ {ok, Tokens, _} =
+ erl_scan:string(lists:flatten(TableDesc++"."), 1, [text]),
+ {ok, Es, Bs} =
+ lib:extended_parse_exprs(Tokens),
+ [Expr] = lib:subst_values_for_vars(Es, Bs),
+ special(Expr);
false -> % abstract expression
TableDesc
end;
@@ -1210,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) ->
@@ -1367,8 +1392,10 @@ next_loop(Pid, L, N) when N =/= 0 ->
{caught, throw, Error, [?THROWN_ERROR | _]} ->
Error;
{caught, Class, Reason, Stacktrace} ->
- _ = (catch erlang:error(foo)),
- erlang:raise(Class, Reason, Stacktrace ++ erlang:get_stacktrace());
+ CurrentStacktrace = try erlang:error(foo)
+ catch error:_ -> erlang:get_stacktrace()
+ end,
+ erlang:raise(Class, Reason, Stacktrace ++ CurrentStacktrace);
error ->
erlang:error({qlc_cursor_pid_no_longer_exists, Pid})
end;
diff --git a/lib/stdlib/src/qlc_pt.erl b/lib/stdlib/src/qlc_pt.erl
index 0db63b81f4..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-2016. 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 = [],
@@ -184,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},
@@ -436,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} ->
@@ -1519,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).
@@ -1870,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}.
@@ -1880,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,
@@ -1887,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};
@@ -2484,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}]},
@@ -2888,6 +2889,26 @@ family_list(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/rand.erl b/lib/stdlib/src/rand.erl
index 93409d95df..7a8a5e6d4a 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 and statistical distribution
+%% improvements by the Erlang/OTP team 2017
%% =====================================================================
-module(rand).
@@ -27,34 +30,180 @@
-export([seed_s/1, seed_s/2, seed/1, seed/2,
export_seed/0, export_seed_s/1,
uniform/0, uniform/1, uniform_s/1, uniform_s/2,
- normal/0, normal_s/1
+ jump/0, jump/1,
+ normal/0, normal/2, normal_s/1, normal_s/3
]).
-compile({inline, [exs64_next/1, exsplus_next/1,
exs1024_next/1, exs1024_calc/2,
+ exrop_next/1, exrop_next_s/2,
get_52/1, normal_kiwi/1]}).
--define(DEFAULT_ALG_HANDLER, exsplus).
+-define(DEFAULT_ALG_HANDLER, exrop).
-define(SEED_DICT, rand_seed).
%% =====================================================================
+%% Bit fiddling macros
+%% =====================================================================
+
+-define(BIT(Bits), (1 bsl (Bits))).
+-define(MASK(Bits), (?BIT(Bits) - 1)).
+-define(MASK(Bits, X), ((X) band ?MASK(Bits))).
+-define(
+ BSL(Bits, X, N),
+ %% N is evaluated 2 times
+ (?MASK((Bits)-(N), (X)) bsl (N))).
+-define(
+ ROTL(Bits, X, N),
+ %% Bits is evaluated 2 times
+ %% X is evaluated 2 times
+ %% N i evaluated 3 times
+ (?BSL((Bits), (X), (N)) bor ((X) bsr ((Bits)-(N))))).
+
+%%-define(TWO_POW_MINUS53, (math:pow(2, -53))).
+-define(TWO_POW_MINUS53, 1.11022302462515657e-16).
+
+%% =====================================================================
%% Types
%% =====================================================================
+-type uint64() :: 0..?MASK(64).
+-type uint58() :: 0..?MASK(58).
+
%% This depends on the algorithm handler function
--type alg_seed() :: exs64_state() | exsplus_state() | exs1024_state().
-%% This is the algorithm handler function within this module
--type alg_handler() :: #{type := alg(),
- max := integer(),
- next := fun(),
- uniform := fun(),
- uniform_n := fun()}.
-
-%% Internal state
--opaque state() :: {alg_handler(), alg_seed()}.
--type alg() :: exs64 | exsplus | exs1024.
--opaque export_state() :: {alg(), alg_seed()}.
--export_type([alg/0, state/0, export_state/0]).
+-type alg_state() ::
+ exs64_state() | exsplus_state() | exs1024_state() |
+ exrop_state() | term().
+
+%% This is the algorithm handling definition within this module,
+%% and the type to use for plugins.
+%%
+%% The 'type' field must be recognized by the module that implements
+%% the algorithm, to interpret an exported state.
+%%
+%% The 'bits' field indicates how many bits the integer
+%% returned from 'next' has got, i.e 'next' shall return
+%% an random integer in the range 0..(2^Bits - 1).
+%% At least 53 bits is required for the floating point
+%% producing fallbacks. This field is only used when
+%% the 'uniform' or 'uniform_n' fields are not defined.
+%%
+%% The fields 'next', 'uniform' and 'uniform_n'
+%% implement the algorithm. If 'uniform' or 'uinform_n'
+%% is not present there is a fallback using 'next' and either
+%% 'bits' or the deprecated 'max'.
+%%
+-type alg_handler() ::
+ #{type := alg(),
+ bits => non_neg_integer(),
+ weak_low_bits => non_neg_integer(),
+ max => non_neg_integer(), % Deprecated
+ next :=
+ fun ((alg_state()) -> {non_neg_integer(), alg_state()}),
+ uniform =>
+ fun ((state()) -> {float(), state()}),
+ uniform_n =>
+ fun ((pos_integer(), state()) -> {pos_integer(), state()}),
+ jump =>
+ fun ((state()) -> state())}.
+
+%% Algorithm state
+-type state() :: {alg_handler(), alg_state()}.
+-type builtin_alg() :: exs64 | exsplus | exsp | exs1024 | exs1024s | exrop.
+-type alg() :: builtin_alg() | atom().
+-type export_state() :: {alg(), alg_state()}.
+-export_type(
+ [builtin_alg/0, alg/0, alg_handler/0, alg_state/0,
+ state/0, export_state/0]).
+-export_type(
+ [exs64_state/0, exsplus_state/0, exs1024_state/0, exrop_state/0]).
+
+%% =====================================================================
+%% Range macro and helper
+%% =====================================================================
+
+-define(
+ uniform_range(Range, Alg, R, V, MaxMinusRange, I),
+ if
+ 0 =< (MaxMinusRange) ->
+ if
+ %% Really work saving in odd cases;
+ %% large ranges in particular
+ (V) < (Range) ->
+ {(V) + 1, {(Alg), (R)}};
+ true ->
+ (I) = (V) rem (Range),
+ if
+ (V) - (I) =< (MaxMinusRange) ->
+ {(I) + 1, {(Alg), (R)}};
+ true ->
+ %% V in the truncated top range
+ %% - try again
+ ?FUNCTION_NAME((Range), {(Alg), (R)})
+ end
+ end;
+ true ->
+ uniform_range((Range), (Alg), (R), (V))
+ end).
+
+%% For ranges larger than the algorithm bit size
+uniform_range(Range, #{next:=Next, bits:=Bits} = Alg, R, V) ->
+ WeakLowBits =
+ case Alg of
+ #{weak_low_bits:=WLB} -> WLB;
+ #{} -> 0
+ end,
+ %% Maybe waste the lowest bit(s) when shifting in new bits
+ Shift = Bits - WeakLowBits,
+ ShiftMask = bnot ?MASK(WeakLowBits),
+ RangeMinus1 = Range - 1,
+ if
+ (Range band RangeMinus1) =:= 0 -> % Power of 2
+ %% Generate at least the number of bits for the range
+ {V1, R1, _} =
+ uniform_range(
+ Range bsr Bits, Next, R, V, ShiftMask, Shift, Bits),
+ {(V1 band RangeMinus1) + 1, {Alg, R1}};
+ true ->
+ %% Generate a value with at least two bits more than the range
+ %% and try that for a fit, otherwise recurse
+ %%
+ %% Just one bit more should ensure that the generated
+ %% number range is at least twice the size of the requested
+ %% range, which would make the probability to draw a good
+ %% number better than 0.5. And repeating that until
+ %% success i guess would take 2 times statistically amortized.
+ %% But since the probability for fairly many attemtpts
+ %% is not that low, use two bits more than the range which
+ %% should make the probability to draw a bad number under 0.25,
+ %% which decreases the bad case probability a lot.
+ {V1, R1, B} =
+ uniform_range(
+ Range bsr (Bits - 2), Next, R, V, ShiftMask, Shift, Bits),
+ I = V1 rem Range,
+ if
+ (V1 - I) =< (1 bsl B) - Range ->
+ {I + 1, {Alg, R1}};
+ true ->
+ %% V1 drawn from the truncated top range
+ %% - try again
+ {V2, R2} = Next(R1),
+ uniform_range(Range, Alg, R2, V2)
+ end
+ end.
+%%
+uniform_range(Range, Next, R, V, ShiftMask, Shift, B) ->
+ if
+ Range =< 1 ->
+ {V, R, B};
+ true ->
+ {V1, R1} = Next(R),
+ %% Waste the lowest bit(s) when shifting in new bits
+ uniform_range(
+ Range bsr Shift, Next, R1,
+ ((V band ShiftMask) bsl Shift) bor V1,
+ ShiftMask, Shift, B + Shift)
+ end.
%% =====================================================================
%% API
@@ -68,7 +217,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 +226,37 @@ export_seed_s({#{type:=Alg}, Seed}) -> {Alg, Seed}.
%% seed({Alg,Seed}) setup RNG with a previously exported seed
%% and return the NEW state
--spec seed(AlgOrExpState::alg() | export_state()) -> state().
+-spec seed(
+ AlgOrStateOrExpState :: builtin_alg() | state() | export_state()) ->
+ state().
seed(Alg) ->
- R = seed_s(Alg),
- _ = seed_put(R),
- R.
+ seed_put(seed_s(Alg)).
--spec seed_s(AlgOrExpState::alg() | export_state()) -> state().
-seed_s(Alg) when is_atom(Alg) ->
- seed_s(Alg, {erlang:phash2([{node(),self()}]),
- erlang:system_time(),
- erlang:unique_integer()});
+-spec seed_s(
+ AlgOrStateOrExpState :: builtin_alg() | state() | export_state()) ->
+ state().
+seed_s({AlgHandler, _Seed} = State) when is_map(AlgHandler) ->
+ State;
seed_s({Alg0, Seed}) ->
{Alg,_SeedFun} = mk_alg(Alg0),
- {Alg, Seed}.
+ {Alg, Seed};
+seed_s(Alg) ->
+ seed_s(Alg, {erlang:phash2([{node(),self()}]),
+ erlang:system_time(),
+ erlang:unique_integer()}).
%% seed/2: seeds RNG with the algorithm and given values
%% and returns the NEW state.
--spec seed(Alg :: alg(), {integer(), integer(), integer()}) -> state().
+-spec seed(
+ Alg :: builtin_alg(), Seed :: {integer(), integer(), integer()}) ->
+ state().
seed(Alg0, S0) ->
- State = seed_s(Alg0, S0),
- _ = seed_put(State),
- State.
+ seed_put(seed_s(Alg0, S0)).
--spec seed_s(Alg :: alg(), {integer(), integer(), integer()}) -> state().
+-spec seed_s(
+ Alg :: builtin_alg(), Seed :: {integer(), integer(), integer()}) ->
+ state().
seed_s(Alg0, S0 = {_, _, _}) ->
{Alg, Seed} = mk_alg(Alg0),
AS = Seed(S0),
@@ -110,10 +265,10 @@ seed_s(Alg0, S0 = {_, _, _}) ->
%%% uniform/0, uniform/1, uniform_s/1, uniform_s/2 are all
%%% uniformly distributed random numbers.
-%% uniform/0: returns a random float X where 0.0 < X < 1.0,
+%% uniform/0: returns a random float X where 0.0 =< X < 1.0,
%% updating the state in the process dictionary.
--spec uniform() -> X::float().
+-spec uniform() -> X :: float().
uniform() ->
{X, Seed} = uniform_s(seed_get()),
_ = seed_put(Seed),
@@ -123,32 +278,76 @@ uniform() ->
%% uniform/1 returns a random integer X where 1 =< X =< N,
%% updating the state in the process dictionary.
--spec uniform(N :: pos_integer()) -> X::pos_integer().
+-spec uniform(N :: pos_integer()) -> X :: pos_integer().
uniform(N) ->
{X, Seed} = uniform_s(N, seed_get()),
_ = seed_put(Seed),
X.
%% uniform_s/1: given a state, uniform_s/1
-%% returns a random float X where 0.0 < X < 1.0,
+%% returns a random float X where 0.0 =< X < 1.0,
%% and a new state.
--spec uniform_s(state()) -> {X::float(), NewS :: state()}.
+-spec uniform_s(State :: state()) -> {X :: float(), NewState :: state()}.
uniform_s(State = {#{uniform:=Uniform}, _}) ->
- Uniform(State).
+ Uniform(State);
+uniform_s({#{bits:=Bits, next:=Next} = Alg, R0}) ->
+ {V, R1} = Next(R0),
+ %% Produce floats on the form N * 2^(-53)
+ {(V bsr (Bits - 53)) * ?TWO_POW_MINUS53, {Alg, R1}};
+uniform_s({#{max:=Max, next:=Next} = Alg, R0}) ->
+ {V, R1} = Next(R0),
+ %% Old broken algorithm with non-uniform density
+ {V / (Max + 1), {Alg, R1}}.
+
%% uniform_s/2: given an integer N >= 1 and a state, uniform_s/2
%% uniform_s/2 returns a random integer X where 1 =< X =< N,
%% and a new state.
--spec uniform_s(N::pos_integer(), state()) -> {X::pos_integer(), NewS::state()}.
-uniform_s(N, State = {#{uniform_n:=Uniform, max:=Max}, _})
- when 0 < N, N =< Max ->
- Uniform(N, State);
-uniform_s(N, State0 = {#{uniform:=Uniform}, _})
- when is_integer(N), 0 < N ->
- {F, State} = Uniform(State0),
- {trunc(F * N) + 1, State}.
+-spec uniform_s(N :: pos_integer(), State :: state()) ->
+ {X :: pos_integer(), NewState :: state()}.
+uniform_s(N, State = {#{uniform_n:=UniformN}, _})
+ when is_integer(N), 1 =< N ->
+ UniformN(N, State);
+uniform_s(N, {#{bits:=Bits, next:=Next} = Alg, R0})
+ when is_integer(N), 1 =< N ->
+ {V, R1} = Next(R0),
+ MaxMinusN = ?BIT(Bits) - N,
+ ?uniform_range(N, Alg, R1, V, MaxMinusN, I);
+uniform_s(N, {#{max:=Max, next:=Next} = Alg, R0})
+ when is_integer(N), 1 =< N ->
+ %% Old broken algorithm with skewed probability
+ %% and gap in ranges > Max
+ {V, R1} = Next(R0),
+ if
+ N =< Max ->
+ {(V rem N) + 1, {Alg, R1}};
+ true ->
+ F = V / (Max + 1),
+ {trunc(F * N) + 1, {Alg, R1}}
+ end.
+
+%% jump/1: given a state, jump/1
+%% returns a new state which is equivalent to that
+%% after a large number of call defined for each algorithm.
+%% The large number is algorithm dependent.
+
+-spec jump(state()) -> NewState :: state().
+jump(State = {#{jump:=Jump}, _}) ->
+ Jump(State);
+jump({#{}, _}) ->
+ erlang:error(not_implemented).
+
+
+%% jump/0: read the internal state and
+%% apply the jump function for the state as in jump/1
+%% and write back the new value to the internal state,
+%% then returns the new value.
+
+-spec jump() -> NewState :: state().
+jump() ->
+ seed_put(jump(seed_get())).
%% normal/0: returns a random float with standard normal distribution
%% updating the state in the process dictionary.
@@ -159,14 +358,21 @@ normal() ->
_ = seed_put(Seed),
X.
+%% normal/2: returns a random float with N(μ, σ²) normal distribution
+%% updating the state in the process dictionary.
+
+-spec normal(Mean :: number(), Variance :: number()) -> float().
+normal(Mean, Variance) ->
+ Mean + (math:sqrt(Variance) * normal()).
+
%% normal_s/1: returns a random float with standard normal distribution
%% The Ziggurat Method for generating random variables - Marsaglia and Tsang
%% Paper and reference code: http://www.jstatsoft.org/v05/i08/
--spec normal_s(state()) -> {float(), NewS :: state()}.
+-spec normal_s(State :: state()) -> {float(), NewState :: state()}.
normal_s(State0) ->
{Sign, R, State} = get_52(State0),
- Idx = R band 16#FF,
+ Idx = ?MASK(8, R),
Idx1 = Idx+1,
{Ki, Wi} = normal_kiwi(Idx1),
X = R * Wi,
@@ -179,22 +385,20 @@ normal_s(State0) ->
false -> normal_s(Idx, Sign, -X, State)
end.
-%% =====================================================================
-%% Internal functions
+%% normal_s/3: returns a random float with normal N(μ, σ²) distribution
--define(UINT21MASK, 16#00000000001fffff).
--define(UINT32MASK, 16#00000000ffffffff).
--define(UINT33MASK, 16#00000001ffffffff).
--define(UINT39MASK, 16#0000007fffffffff).
--define(UINT58MASK, 16#03ffffffffffffff).
--define(UINT64MASK, 16#ffffffffffffffff).
+-spec normal_s(Mean :: number(), Variance :: number(), state()) -> {float(), NewS :: state()}.
+normal_s(Mean, Variance, State0) when Variance > 0 ->
+ {X, State} = normal_s(State0),
+ {Mean + (math:sqrt(Variance) * X), State}.
--type uint64() :: 0..16#ffffffffffffffff.
--type uint58() :: 0..16#03ffffffffffffff.
+%% =====================================================================
+%% Internal functions
--spec seed_put(state()) -> undefined | state().
+-spec seed_put(state()) -> state().
seed_put(Seed) ->
- put(?SEED_DICT, Seed).
+ put(?SEED_DICT, Seed),
+ Seed.
seed_get() ->
case get(?SEED_DICT) of
@@ -204,17 +408,30 @@ seed_get() ->
%% Setup alg record
mk_alg(exs64) ->
- {#{type=>exs64, max=>?UINT64MASK, next=>fun exs64_next/1,
- uniform=>fun exs64_uniform/1, uniform_n=>fun exs64_uniform/2},
+ {#{type=>exs64, max=>?MASK(64), next=>fun exs64_next/1},
fun exs64_seed/1};
mk_alg(exsplus) ->
- {#{type=>exsplus, max=>?UINT58MASK, next=>fun exsplus_next/1,
- uniform=>fun exsplus_uniform/1, uniform_n=>fun exsplus_uniform/2},
+ {#{type=>exsplus, max=>?MASK(58), next=>fun exsplus_next/1,
+ jump=>fun exsplus_jump/1},
+ fun exsplus_seed/1};
+mk_alg(exsp) ->
+ {#{type=>exsp, bits=>58, weak_low_bits=>1, next=>fun exsplus_next/1,
+ uniform=>fun exsp_uniform/1, uniform_n=>fun exsp_uniform/2,
+ jump=>fun exsplus_jump/1},
fun exsplus_seed/1};
mk_alg(exs1024) ->
- {#{type=>exs1024, max=>?UINT64MASK, next=>fun exs1024_next/1,
- uniform=>fun exs1024_uniform/1, uniform_n=>fun exs1024_uniform/2},
- fun exs1024_seed/1}.
+ {#{type=>exs1024, max=>?MASK(64), next=>fun exs1024_next/1,
+ jump=>fun exs1024_jump/1},
+ fun exs1024_seed/1};
+mk_alg(exs1024s) ->
+ {#{type=>exs1024s, bits=>64, weak_low_bits=>3, next=>fun exs1024_next/1,
+ jump=>fun exs1024_jump/1},
+ fun exs1024_seed/1};
+mk_alg(exrop) ->
+ {#{type=>exrop, bits=>58, weak_low_bits=>1, next=>fun exrop_next/1,
+ uniform=>fun exrop_uniform/1, uniform_n=>fun exrop_uniform/2,
+ jump=>fun exrop_jump/1},
+ fun exrop_seed/1}.
%% =====================================================================
%% exs64 PRNG: Xorshift64*
@@ -222,29 +439,21 @@ mk_alg(exs1024) ->
%% Reference URL: http://xorshift.di.unimi.it/
%% =====================================================================
--type exs64_state() :: uint64().
+-opaque exs64_state() :: uint64().
exs64_seed({A1, A2, A3}) ->
- {V1, _} = exs64_next(((A1 band ?UINT32MASK) * 4294967197 + 1)),
- {V2, _} = exs64_next(((A2 band ?UINT32MASK) * 4294967231 + 1)),
- {V3, _} = exs64_next(((A3 band ?UINT32MASK) * 4294967279 + 1)),
- ((V1 * V2 * V3) rem (?UINT64MASK - 1)) + 1.
+ {V1, _} = exs64_next((?MASK(32, A1) * 4294967197 + 1)),
+ {V2, _} = exs64_next((?MASK(32, A2) * 4294967231 + 1)),
+ {V3, _} = exs64_next((?MASK(32, A3) * 4294967279 + 1)),
+ ((V1 * V2 * V3) rem (?MASK(64) - 1)) + 1.
%% Advance xorshift64* state for one step and generate 64bit unsigned integer
-spec exs64_next(exs64_state()) -> {uint64(), exs64_state()}.
exs64_next(R) ->
R1 = R bxor (R bsr 12),
- R2 = R1 bxor ((R1 band ?UINT39MASK) bsl 25),
+ R2 = R1 bxor ?BSL(64, R1, 25),
R3 = R2 bxor (R2 bsr 27),
- {(R3 * 2685821657736338717) band ?UINT64MASK, R3}.
-
-exs64_uniform({Alg, R0}) ->
- {V, R1} = exs64_next(R0),
- {V / 18446744073709551616, {Alg, R1}}.
-
-exs64_uniform(Max, {Alg, R}) ->
- {V, R1} = exs64_next(R),
- {(V rem Max) + 1, {Alg, R1}}.
+ {?MASK(64, R3 * 2685821657736338717), R3}.
%% =====================================================================
%% exsplus PRNG: Xorshift116+
@@ -254,15 +463,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 +482,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 +539,12 @@ exsplus_uniform(Max, {Alg, R}) ->
%% Reference URL: http://xorshift.di.unimi.it/
%% =====================================================================
--type exs1024_state() :: {list(uint64()), list(uint64())}.
+-opaque exs1024_state() :: {list(uint64()), list(uint64())}.
exs1024_seed({A1, A2, A3}) ->
- B1 = (((A1 band ?UINT21MASK) + 1) * 2097131) band ?UINT21MASK,
- B2 = (((A2 band ?UINT21MASK) + 1) * 2097133) band ?UINT21MASK,
- B3 = (((A3 band ?UINT21MASK) + 1) * 2097143) band ?UINT21MASK,
+ B1 = ?MASK(21, (?MASK(21, A1) + 1) * 2097131),
+ B2 = ?MASK(21, (?MASK(21, A2) + 1) * 2097133),
+ B3 = ?MASK(21, (?MASK(21, A3) + 1) * 2097143),
{exs1024_gen1024((B1 bsl 43) bor (B2 bsl 22) bor (B3 bsl 1) bor 1),
[]}.
@@ -317,11 +567,11 @@ exs1024_gen1024(N, R, L) ->
%% X: random number output
-spec exs1024_calc(uint64(), uint64()) -> {uint64(), uint64()}.
exs1024_calc(S0, S1) ->
- S11 = S1 bxor ((S1 band ?UINT33MASK) bsl 31),
+ S11 = S1 bxor ?BSL(64, S1, 31),
S12 = S11 bxor (S11 bsr 11),
S01 = S0 bxor (S0 bsr 30),
NS1 = S01 bxor S12,
- {(NS1 * 1181783497276652981) band ?UINT64MASK, NS1}.
+ {?MASK(64, NS1 * 1181783497276652981), NS1}.
%% Advance xorshift1024* state for one step and generate 64bit unsigned integer
-spec exs1024_next(exs1024_state()) -> {uint64(), exs1024_state()}.
@@ -332,13 +582,190 @@ exs1024_next({[H], RL}) ->
NL = [H|lists:reverse(RL)],
exs1024_next({NL, []}).
-exs1024_uniform({Alg, R0}) ->
- {V, R1} = exs1024_next(R0),
- {V / 18446744073709551616, {Alg, R1}}.
-exs1024_uniform(Max, {Alg, R}) ->
- {V, R1} = exs1024_next(R),
- {(V rem Max) + 1, {Alg, R1}}.
+%% This is the jump function for the exs1024 generator, equivalent
+%% to 2^512 calls to next(); it can be used to generate 2^512
+%% non-overlapping subsequences for parallel computations.
+%% Note: the jump function takes ~2000 times of the execution time of
+%% next/1.
+
+%% Jump constant here split into 58 bits for speed
+-define(JUMPCONSTHEAD, 16#00242f96eca9c41d).
+-define(JUMPCONSTTAIL,
+ [16#0196e1ddbe5a1561,
+ 16#0239f070b5837a3c,
+ 16#03f393cc68796cd2,
+ 16#0248316f404489af,
+ 16#039a30088bffbac2,
+ 16#02fea70dc2d9891f,
+ 16#032ae0d9644caec4,
+ 16#0313aac17d8efa43,
+ 16#02f132e055642626,
+ 16#01ee975283d71c93,
+ 16#00552321b06f5501,
+ 16#00c41d10a1e6a569,
+ 16#019158ecf8aa1e44,
+ 16#004e9fc949d0b5fc,
+ 16#0363da172811fdda,
+ 16#030e38c3b99181f2,
+ 16#0000000a118038fc]).
+-define(JUMPTOTALLEN, 1024).
+-define(RINGLEN, 16).
+
+-spec exs1024_jump(state()) -> state().
+
+exs1024_jump({Alg, {L, RL}}) ->
+ P = length(RL),
+ AS = exs1024_jump({L, RL},
+ [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0],
+ ?JUMPCONSTTAIL, ?JUMPCONSTHEAD, ?JUMPELEMLEN, ?JUMPTOTALLEN),
+ {ASL, ASR} = lists:split(?RINGLEN - P, AS),
+ {Alg, {ASL, lists:reverse(ASR)}}.
+
+exs1024_jump(_, AS, _, _, _, 0) ->
+ AS;
+exs1024_jump(S, AS, [H|T], _, 0, TN) ->
+ exs1024_jump(S, AS, T, H, ?JUMPELEMLEN, TN);
+exs1024_jump({L, RL}, AS, JL, J, N, TN) ->
+ {_, NS} = exs1024_next({L, RL}),
+ case ?MASK(1, J) of
+ 1 ->
+ AS2 = lists:zipwith(fun(X, Y) -> X bxor Y end,
+ AS, L ++ lists:reverse(RL)),
+ exs1024_jump(NS, AS2, JL, J bsr 1, N-1, TN-1);
+ 0 ->
+ exs1024_jump(NS, AS, JL, J bsr 1, N-1, TN-1)
+ end.
+
+%% =====================================================================
+%% exrop PRNG: Xoroshiro116+
+%%
+%% Reference URL: http://xorshift.di.unimi.it/
+%%
+%% 58 bits fits into an immediate on 64bits Erlang and is thus much faster.
+%% In fact, an immediate number is 60 bits signed in Erlang so you can
+%% add two positive 58 bit numbers and get a 59 bit number that still is
+%% a positive immediate, which is a property we utilize here...
+%%
+%% Modification of the original Xororhiro128+ algorithm to 116 bits
+%% by Sebastiano Vigna. A lot of thanks for his help and work.
+%% =====================================================================
+%% (a, b, c) = (24, 2, 35)
+%% JUMP Polynomial = 0x9863200f83fcd4a11293241fcb12a (116 bit)
+%%
+%% From http://xoroshiro.di.unimi.it/xoroshiro116plus.c:
+%% ---------------------------------------------------------------------
+%% /* Written in 2017 by Sebastiano Vigna ([email protected]).
+%%
+%% To the extent possible under law, the author has dedicated all copyright
+%% and related and neighboring rights to this software to the public domain
+%% worldwide. This software is distributed without any warranty.
+%%
+%% See <http://creativecommons.org/publicdomain/zero/1.0/>. */
+%%
+%% #include <stdint.h>
+%%
+%% #define UINT58MASK (uint64_t)((UINT64_C(1) << 58) - 1)
+%%
+%% uint64_t s[2];
+%%
+%% static inline uint64_t rotl58(const uint64_t x, int k) {
+%% return (x << k) & UINT58MASK | (x >> (58 - k));
+%% }
+%%
+%% uint64_t next(void) {
+%% uint64_t s1 = s[1];
+%% const uint64_t s0 = s[0];
+%% const uint64_t result = (s0 + s1) & UINT58MASK;
+%%
+%% s1 ^= s0;
+%% s[0] = rotl58(s0, 24) ^ s1 ^ ((s1 << 2) & UINT58MASK); // a, b
+%% s[1] = rotl58(s1, 35); // c
+%% return result;
+%% }
+%%
+%% void jump(void) {
+%% static const uint64_t JUMP[] =
+%% { 0x4a11293241fcb12a, 0x0009863200f83fcd };
+%%
+%% uint64_t s0 = 0;
+%% uint64_t s1 = 0;
+%% for(int i = 0; i < sizeof JUMP / sizeof *JUMP; i++)
+%% for(int b = 0; b < 64; b++) {
+%% if (JUMP[i] & UINT64_C(1) << b) {
+%% s0 ^= s[0];
+%% s1 ^= s[1];
+%% }
+%% next();
+%% }
+%% s[0] = s0;
+%% s[1] = s1;
+%% }
+
+-opaque exrop_state() :: nonempty_improper_list(uint58(), uint58()).
+
+-dialyzer({no_improper_lists, exrop_seed/1}).
+exrop_seed({A1, A2, A3}) ->
+ [_|S1] =
+ exrop_next_s(
+ ?MASK(58, (A1 * 4294967197) + 1),
+ ?MASK(58, (A2 * 4294967231) + 1)),
+ exrop_next_s(?MASK(58, (A3 * 4294967279) + 1), S1).
+
+-dialyzer({no_improper_lists, exrop_next_s/2}).
+%% Advance xoroshiro116+ state one step
+%% [a, b, c] = [24, 2, 35]
+-define(
+ exrop_next_s(S0, S1, S1_a),
+ begin
+ S1_a = S1 bxor S0,
+ [?ROTL(58, S0, 24) bxor S1_a bxor ?BSL(58, S1_a, 2)| % a, b
+ ?ROTL(58, S1_a, 35)] % c
+ end).
+exrop_next_s(S0, S1) ->
+ ?exrop_next_s(S0, S1, S1_a).
+
+-dialyzer({no_improper_lists, exrop_next/1}).
+%% Advance xoroshiro116+ state one step, generate 58 bit unsigned integer,
+%% and waste the lowest bit since it is of lower randomness quality
+exrop_next([S0|S1]) ->
+ {?MASK(58, S0 + S1), ?exrop_next_s(S0, S1, S1_a)}.
+
+exrop_uniform({Alg, R}) ->
+ {V, R1} = exrop_next(R),
+ %% Waste the lowest bit since it is of lower
+ %% randomness quality than the others
+ {(V bsr (58-53)) * ?TWO_POW_MINUS53, {Alg, R1}}.
+
+exrop_uniform(Range, {Alg, R}) ->
+ {V, R1} = exrop_next(R),
+ MaxMinusRange = ?BIT(58) - Range,
+ ?uniform_range(Range, Alg, R1, V, MaxMinusRange, I).
+
+%% Split a 116 bit constant into two 58 bit words,
+%% a top '1' marks the end of the low word.
+-define(
+ JUMP_116(Jump),
+ [?BIT(58) bor ?MASK(58, (Jump)),(Jump) bsr 58]).
+%%
+exrop_jump({Alg,S}) ->
+ [J|Js] = ?JUMP_116(16#9863200f83fcd4a11293241fcb12a),
+ {Alg, exrop_jump(S, 0, 0, J, Js)}.
+%%
+-dialyzer({no_improper_lists, exrop_jump/5}).
+exrop_jump(_S, S0, S1, 0, []) -> % End of jump constant
+ [S0|S1];
+exrop_jump(S, S0, S1, 1, [J|Js]) -> % End of word
+ exrop_jump(S, S0, S1, J, Js);
+exrop_jump([S__0|S__1] = _S, S0, S1, J, Js) ->
+ case ?MASK(1, J) of
+ 1 ->
+ NewS = exrop_next_s(S__0, S__1),
+ exrop_jump(NewS, S0 bxor S__0, S1 bxor S__1, J bsr 1, Js);
+ 0 ->
+ NewS = exrop_next_s(S__0, S__1),
+ exrop_jump(NewS, S0, S1, J bsr 1, Js)
+ end.
%% =====================================================================
%% Ziggurat cont
@@ -347,9 +774,13 @@ exs1024_uniform(Max, {Alg, R}) ->
-define(NOR_INV_R, 1/?NOR_R).
%% return a {sign, Random51bits, State}
+get_52({Alg=#{bits:=Bits, next:=Next}, S0}) ->
+ %% Use the high bits
+ {Int,S1} = Next(S0),
+ {?BIT(Bits - 51 - 1) band Int, Int bsr (Bits - 51), {Alg, S1}};
get_52({Alg=#{next:=Next}, S0}) ->
{Int,S1} = Next(S0),
- {((1 bsl 51) band Int), Int band ((1 bsl 51)-1), {Alg, S1}}.
+ {?BIT(51) band Int, ?MASK(51, Int), {Alg, S1}}.
%% Slow path
normal_s(0, Sign, X0, State0) ->
diff --git a/lib/stdlib/src/re.erl b/lib/stdlib/src/re.erl
index 52d3c35608..726b409d4d 100644
--- a/lib/stdlib/src/re.erl
+++ b/lib/stdlib/src/re.erl
@@ -1,7 +1,7 @@
%%
%% %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.
@@ -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 3e70450320..c65a13b22e 100644
--- a/lib/stdlib/src/sets.erl
+++ b/lib/stdlib/src/sets.erl
@@ -128,14 +128,14 @@ is_element(E, S) ->
Set2 :: set(Element).
add_element(E, S0) ->
Slot = get_slot(S0, E),
- {S1,Ic} = on_bucket(fun (B0) -> add_bkt_el(E, B0, B0) end, S0, Slot),
- maybe_expand(S1, Ic).
-
--spec add_bkt_el(T, [T], [T]) -> {[T], 0 | 1}.
-add_bkt_el(E, [E|_], Bkt) -> {Bkt,0};
-add_bkt_el(E, [_|B], Bkt) ->
- add_bkt_el(E, B, Bkt);
-add_bkt_el(E, [], Bkt) -> {[E|Bkt],1}.
+ Bkt = get_bucket(S0, Slot),
+ case lists:member(E, Bkt) of
+ true ->
+ S0;
+ false ->
+ S1 = update_bucket(S0, Slot, [E | Bkt]),
+ maybe_expand(S1)
+ end.
%% del_element(Element, Set) -> Set.
%% Return Set but with Element removed.
@@ -144,15 +144,28 @@ add_bkt_el(E, [], Bkt) -> {[E|Bkt],1}.
Set2 :: set(Element).
del_element(E, S0) ->
Slot = get_slot(S0, E),
- {S1,Dc} = on_bucket(fun (B0) -> del_bkt_el(E, B0) end, S0, Slot),
- maybe_contract(S1, Dc).
+ Bkt = get_bucket(S0, Slot),
+ case lists:member(E, Bkt) of
+ false ->
+ S0;
+ true ->
+ S1 = update_bucket(S0, Slot, lists:delete(E, Bkt)),
+ maybe_contract(S1, 1)
+ end.
--spec del_bkt_el(T, [T]) -> {[T], 0 | 1}.
-del_bkt_el(E, [E|Bkt]) -> {Bkt,1};
-del_bkt_el(E, [Other|Bkt0]) ->
- {Bkt1,Dc} = del_bkt_el(E, Bkt0),
- {[Other|Bkt1],Dc};
-del_bkt_el(_, []) -> {[],0}.
+%% update_bucket(Set, Slot, NewBucket) -> UpdatedSet.
+%% Replace bucket in Slot by NewBucket
+-spec update_bucket(Set1, Slot, Bkt) -> Set2 when
+ Set1 :: set(Element),
+ Set2 :: set(Element),
+ Slot :: non_neg_integer(),
+ Bkt :: [Element].
+update_bucket(Set, Slot, NewBucket) ->
+ SegI = ((Slot-1) div ?seg_size) + 1,
+ BktI = ((Slot-1) rem ?seg_size) + 1,
+ Segs = Set#set.segs,
+ Seg = element(SegI, Segs),
+ Set#set{segs = setelement(SegI, Segs, setelement(BktI, Seg, NewBucket))}.
%% union(Set1, Set2) -> Set
%% Return the union of Set1 and Set2.
@@ -272,19 +285,6 @@ get_slot(T, Key) ->
-spec get_bucket(set(), non_neg_integer()) -> term().
get_bucket(T, Slot) -> get_bucket_s(T#set.segs, Slot).
-%% on_bucket(Fun, Hashdb, Slot) -> {NewHashDb,Result}.
-%% Apply Fun to the bucket in Slot and replace the returned bucket.
--spec on_bucket(fun((_) -> {[_], 0 | 1}), set(E), non_neg_integer()) ->
- {set(E), 0 | 1}.
-on_bucket(F, T, Slot) ->
- SegI = ((Slot-1) div ?seg_size) + 1,
- BktI = ((Slot-1) rem ?seg_size) + 1,
- Segs = T#set.segs,
- Seg = element(SegI, Segs),
- B0 = element(BktI, Seg),
- {B1, Res} = F(B0), %Op on the bucket.
- {T#set{segs = setelement(SegI, Segs, setelement(BktI, Seg, B1))},Res}.
-
%% fold_set(Fun, Acc, Dictionary) -> Dictionary.
%% filter_set(Fun, Dictionary) -> Dictionary.
@@ -349,8 +349,8 @@ put_bucket_s(Segs, Slot, Bkt) ->
Seg = setelement(BktI, element(SegI, Segs), Bkt),
setelement(SegI, Segs, Seg).
--spec maybe_expand(set(E), 0 | 1) -> set(E).
-maybe_expand(T0, Ic) when T0#set.size + Ic > T0#set.exp_size ->
+-spec maybe_expand(set(E)) -> set(E).
+maybe_expand(T0) when T0#set.size + 1 > T0#set.exp_size ->
T = maybe_expand_segs(T0), %Do we need more segments.
N = T#set.n + 1, %Next slot to expand into
Segs0 = T#set.segs,
@@ -360,12 +360,12 @@ maybe_expand(T0, Ic) when T0#set.size + Ic > T0#set.exp_size ->
{B1,B2} = rehash(B, Slot1, Slot2, T#set.maxn),
Segs1 = put_bucket_s(Segs0, Slot1, B1),
Segs2 = put_bucket_s(Segs1, Slot2, B2),
- T#set{size = T#set.size + Ic,
+ T#set{size = T#set.size + 1,
n = N,
exp_size = N * ?expand_load,
con_size = N * ?contract_load,
segs = Segs2};
-maybe_expand(T, Ic) -> T#set{size = T#set.size + Ic}.
+maybe_expand(T) -> T#set{size = T#set.size + 1}.
-spec maybe_expand_segs(set(E)) -> set(E).
maybe_expand_segs(T) when T#set.n =:= T#set.maxn ->
diff --git a/lib/stdlib/src/shell.erl b/lib/stdlib/src/shell.erl
index 28f37ef8bf..26b3960f4f 100644
--- a/lib/stdlib/src/shell.erl
+++ b/lib/stdlib/src/shell.erl
@@ -1,7 +1,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 1996-2016. 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.
@@ -229,8 +229,9 @@ server_loop(N0, Eval_0, Bs00, RT, Ds00, History0, Results0) ->
{Eval_1,Bs0,Ds0,Prompt} = prompt(N, Eval_0, Bs00, RT, Ds00),
{Res,Eval0} = get_command(Prompt, Eval_1, Bs0, RT, Ds0),
case Res of
- {ok,Es0} ->
- case expand_hist(Es0, N) of
+ {ok,Es0,XBs} ->
+ Es1 = lib:subst_values_for_vars(Es0, XBs),
+ case expand_hist(Es1, N) of
{ok,Es} ->
{V,Eval,Bs,Ds} = shell_cmd(Es, Eval0, Bs0, RT, Ds0, cmd),
{History,Results} = check_and_get_history_and_results(),
@@ -276,10 +277,10 @@ get_command(Prompt, Eval, Bs, RT, Ds) ->
fun() ->
exit(
case
- io:scan_erl_exprs(group_leader(), Prompt, 1)
+ io:scan_erl_exprs(group_leader(), Prompt, 1, [text])
of
{ok,Toks,_EndPos} ->
- erl_parse:parse_exprs(Toks);
+ lib:extended_parse_exprs(Toks);
{eof,_EndPos} ->
eof;
{error,ErrorInfo,_EndPos} ->
@@ -726,7 +727,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 +737,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.
@@ -967,10 +974,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} ->
@@ -1236,22 +1244,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) ->
@@ -1417,9 +1425,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
diff --git a/lib/stdlib/src/shell_default.erl b/lib/stdlib/src/shell_default.erl
index 6947cf181b..a0c1d98513 100644
--- a/lib/stdlib/src/shell_default.erl
+++ b/lib/stdlib/src/shell_default.erl
@@ -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/sofs.erl b/lib/stdlib/src/sofs.erl
index c244e06ca4..cc50e1b52c 100644
--- a/lib/stdlib/src/sofs.erl
+++ b/lib/stdlib/src/sofs.erl
@@ -1,7 +1,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 2001-2016. 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,7 +584,7 @@ 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.
%%%
@@ -636,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
@@ -646,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
@@ -656,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
@@ -679,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.
@@ -703,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.
@@ -720,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
@@ -741,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
@@ -755,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
@@ -773,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
@@ -787,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
@@ -798,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
@@ -816,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
@@ -836,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
@@ -850,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
@@ -879,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;
@@ -894,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
@@ -909,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.
%%%
@@ -932,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
@@ -945,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) ->
@@ -963,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.
@@ -1000,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
@@ -1013,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) ->
@@ -1032,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 ->
@@ -1053,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.
@@ -1068,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));
_ ->
@@ -1087,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, []),
@@ -1102,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.
@@ -1139,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 ->
@@ -1161,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
@@ -1176,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) ->
@@ -1195,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 ->
@@ -1216,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.
@@ -1234,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
@@ -1246,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 ->
@@ -1294,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
@@ -1314,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
@@ -1328,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
@@ -1341,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
@@ -1354,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
@@ -1367,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
@@ -1382,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
@@ -1394,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
@@ -1428,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
@@ -1446,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)));
@@ -1464,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.
@@ -1499,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.
%%%
@@ -1519,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
@@ -1530,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
@@ -1560,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.
%%
@@ -1713,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 09176d2ca0..3c449d3cb9 100644
--- a/lib/stdlib/src/stdlib.app.src
+++ b/lib/stdlib/src/stdlib.app.src
@@ -2,7 +2,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 1996-2016. All Rights Reserved.
+%% Copyright Ericsson AB 1996-2017. All Rights Reserved.
%%
%% Licensed under the Apache License, Version 2.0 (the "License");
%% you may not use this file except in compliance with the License.
@@ -31,7 +31,6 @@
dets_server,
dets_sup,
dets_utils,
- dets_v8,
dets_v9,
dict,
digraph,
@@ -40,6 +39,7 @@
edlin_expand,
epp,
eval_bits,
+ erl_abstract_code,
erl_anno,
erl_bits,
erl_compile,
@@ -100,13 +100,14 @@
sys,
timer,
unicode,
+ unicode_util,
win32reg,
zip]},
{registered,[timer_server,rsh_starter,take_over_monitor,pool_master,
dets]},
{applications, [kernel]},
{env, []},
- {runtime_dependencies, ["sasl-3.0","kernel-5.0","erts-8.0","crypto-3.3",
+ {runtime_dependencies, ["sasl-3.0","kernel-5.0","erts-9.0","crypto-3.3",
"compiler-5.0"]}
]}.
diff --git a/lib/stdlib/src/stdlib.appup.src b/lib/stdlib/src/stdlib.appup.src
index 3aa4ec6dab..3100504a80 100644
--- a/lib/stdlib/src/stdlib.appup.src
+++ b/lib/stdlib/src/stdlib.appup.src
@@ -18,9 +18,7 @@
%% %CopyrightEnd%
{"%VSN%",
%% Up from - max one major revision back
- [{<<"3\\.[0-3](\\.[0-9]+)*">>,[restart_new_emulator]}, % OTP-19.*
- {<<"2\\.[5-8](\\.[0-9]+)*">>,[restart_new_emulator]}], % OTP-18.*
+ [{<<"3\\.[0-3](\\.[0-9]+)*">>,[restart_new_emulator]}], % OTP-19.*
%% Down to - max one major revision back
- [{<<"3\\.[0-3](\\.[0-9]+)*">>,[restart_new_emulator]}, % OTP-19.*
- {<<"2\\.[5-8](\\.[0-9]+)*">>,[restart_new_emulator]}] % OTP-18.*
+ [{<<"3\\.[0-3](\\.[0-9]+)*">>,[restart_new_emulator]}] % OTP-19.*
}.
diff --git a/lib/stdlib/src/string.erl b/lib/stdlib/src/string.erl
index c659db78bd..4972da297d 100644
--- a/lib/stdlib/src/string.erl
+++ b/lib/stdlib/src/string.erl
@@ -1,7 +1,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 1996-2016. All Rights Reserved.
+%% Copyright Ericsson AB 1996-2017. All Rights Reserved.
%%
%% Licensed under the Apache License, Version 2.0 (the "License");
%% you may not use this file except in compliance with the License.
@@ -17,43 +17,1324 @@
%%
%% %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]).
--import(lists,[reverse/1,member/2]).
+-compile({no_auto_import,[length/1]}).
-%%---------------------------------------------------------------------------
+-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}).
+%%% 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(CD) ->
+ length_1(unicode_util:gc(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(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 ->
+ slice_l(CD, N, is_binary(CD)).
+
+-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 ->
+ slice_trail(slice_l(CD, N, is_binary(CD)), Length);
+slice(CD, N, infinity) ->
+ slice_l(CD, N, is_binary(CD));
+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(Sep) ->
+ trim_l(Str, search_pattern(Sep));
+trim(Str, trailing, Sep) when is_list(Sep) ->
+ trim_t(Str, 0, search_pattern(Sep));
+trim(Str, both, Sep0) when is_list(Sep0) ->
+ Sep = search_pattern(Sep0),
+ trim_t(trim_l(Str,Sep), 0, Sep).
+
+%% Delete trailing newlines or \r\n
+-spec chomp(String::unicode:chardata()) -> unicode:chardata().
+chomp(Str) ->
+ trim_t(Str,0, {[[$\r,$\n],$\n], [$\r,$\n], [<<$\r>>,<<$\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, Sep0, false, leading) ->
+ Sep = search_pattern(Sep0),
+ take_l(Str, Sep, []);
+take(Str, Sep0, true, leading) ->
+ Sep = search_pattern(Sep0),
+ take_lc(Str, Sep, []);
+take(Str, Sep0, false, trailing) ->
+ Sep = search_pattern(Sep0),
+ take_t(Str, 0, Sep);
+take(Str, Sep0, true, trailing) ->
+ Sep = search_pattern(Sep0),
+ take_tc(Str, 0, Sep).
+
+%% Uppercase all chars in Str
+-spec uppercase(String::unicode:chardata()) -> unicode:chardata().
+uppercase(CD) when is_list(CD) ->
+ uppercase_list(CD);
+uppercase(CD) when is_binary(CD) ->
+ uppercase_bin(CD,<<>>).
+
+%% Lowercase all chars in Str
+-spec lowercase(String::unicode:chardata()) -> unicode:chardata().
+lowercase(CD) when is_list(CD) ->
+ lowercase_list(CD);
+lowercase(CD) when is_binary(CD) ->
+ lowercase_bin(CD,<<>>).
+
+%% Make a titlecase of the first char in Str
+-spec titlecase(String::unicode:chardata()) -> unicode:chardata().
+titlecase(CD) when is_list(CD) ->
+ case unicode_util:titlecase(CD) of
+ [GC|Tail] -> append(GC,Tail);
+ Empty -> Empty
+ end;
+titlecase(CD) when is_binary(CD) ->
+ case unicode_util:titlecase(CD) of
+ [CP|Chars] when is_integer(CP) -> <<CP/utf8,Chars/binary>>;
+ [CPs|Chars] ->
+ << << <<CP/utf8>> || CP <- CPs>>/binary, Chars/binary>>;
+ [] -> <<>>
+ end.
+
+%% Make a comparable string of the Str should be used for equality tests only
+-spec casefold(String::unicode:chardata()) -> unicode:chardata().
+casefold(CD) when is_list(CD) ->
+ casefold_list(CD);
+casefold(CD) when is_binary(CD) ->
+ casefold_bin(CD,<<>>).
+
+-spec to_integer(String) -> {Int, Rest} | {'error', Reason} when
+ String :: unicode:chardata(),
+ Int :: integer(),
+ Rest :: unicode:chardata(),
+ Reason :: 'no_integer' | badarg.
+
+to_integer(String) ->
+ try take(String, "+-0123456789") of
+ {Head, Tail} ->
+ case is_empty(Head) of
+ true -> {error, no_integer};
+ false ->
+ List = unicode:characters_to_list(Head),
+ case string:list_to_integer(List) of
+ {error, _} = Err -> Err;
+ {Int, Rest} ->
+ to_number(String, Int, Rest, List, Tail)
+ end
+ end
+ catch _:_ -> {error, badarg}
+ end.
+
+-spec to_float(String) -> {Float, Rest} | {'error', Reason} when
+ String :: unicode:chardata(),
+ Float :: float(),
+ Rest :: unicode:chardata(),
+ Reason :: 'no_float' | 'badarg'.
+
+to_float(String) ->
+ try take(String, "+-0123456789eE.,") of
+ {Head, Tail} ->
+ case is_empty(Head) of
+ true -> {error, no_float};
+ false ->
+ List = unicode:characters_to_list(Head),
+ case string:list_to_float(List) of
+ {error, _} = Err -> Err;
+ {Float, Rest} ->
+ to_number(String, Float, Rest, List, Tail)
+ end
+ end
+ catch _:_ -> {error, badarg}
+ end.
+
+to_number(String, Number, Rest, List, _Tail) when is_binary(String) ->
+ BSz = erlang:length(List)-erlang:length(Rest),
+ <<_:BSz/binary, Cont/binary>> = String,
+ {Number, Cont};
+to_number(_, Number, Rest, _, Tail) ->
+ {Number, concat(Rest,Tail)}.
+
+%% Return the remaining string with prefix removed or else nomatch
+-spec prefix(String::unicode:chardata(), Prefix::unicode:chardata()) ->
+ 'nomatch' | unicode:chardata().
+prefix(Str, []) -> Str;
+prefix(Str, Prefix0) ->
+ Prefix = unicode:characters_to_list(Prefix0),
+ case prefix_1(Str, Prefix) 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, 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 codepoint 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 grapheme cluster 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([_|Rest], N) ->
+ length_1(unicode_util:gc(Rest), N+1);
+length_1([], N) ->
+ N.
+
+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(CD, Acc) ->
+ case unicode_util:gc(CD) of
+ [GC|Rest] -> reverse_1(Rest, [GC|Acc]);
+ [] -> Acc
+ end.
+
+slice_l(CD, N, Binary) when N > 0 ->
+ case unicode_util:gc(CD) of
+ [_|Cont] -> slice_l(Cont, N-1, Binary);
+ [] when Binary -> <<>>;
+ [] -> []
+ end;
+slice_l(Cont, 0, Binary) ->
+ case is_empty(Cont) of
+ true when Binary -> <<>>;
+ _ -> Cont
+ end.
+
+slice_trail(CD, N) when is_list(CD) ->
+ slice_list(CD, N);
+slice_trail(CD, N) when is_binary(CD) ->
+ slice_bin(CD, N, CD).
+
+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(CD, N, Orig) when N > 0 ->
+ case unicode_util:gc(CD) of
+ [_|Cont] -> slice_bin(Cont, N-1, Orig);
+ [] -> Orig
+ end;
+slice_bin([], 0, Orig) ->
+ Orig;
+slice_bin(CD, 0, Orig) ->
+ Sz = byte_size(Orig) - byte_size(CD),
+ <<Keep:Sz/binary, _/binary>> = Orig,
+ Keep.
+
+uppercase_list(CPs0) ->
+ case unicode_util:uppercase(CPs0) of
+ [Char|CPs] -> append(Char,uppercase_list(CPs));
+ [] -> []
+ end.
+
+uppercase_bin(CPs0, Acc) ->
+ case unicode_util:uppercase(CPs0) of
+ [Char|CPs] when is_integer(Char) ->
+ uppercase_bin(CPs, <<Acc/binary, Char/utf8>>);
+ [Chars|CPs] ->
+ uppercase_bin(CPs, <<Acc/binary,
+ << <<CP/utf8>> || CP <- Chars>>/binary >>);
+ [] -> Acc
+ end.
+
+lowercase_list(CPs0) ->
+ case unicode_util:lowercase(CPs0) of
+ [Char|CPs] -> append(Char,lowercase_list(CPs));
+ [] -> []
+ end.
+
+lowercase_bin(CPs0, Acc) ->
+ case unicode_util:lowercase(CPs0) of
+ [Char|CPs] when is_integer(Char) ->
+ lowercase_bin(CPs, <<Acc/binary, Char/utf8>>);
+ [Chars|CPs] ->
+ lowercase_bin(CPs, <<Acc/binary,
+ << <<CP/utf8>> || CP <- Chars>>/binary >>);
+ [] -> Acc
+ end.
+
+casefold_list(CPs0) ->
+ case unicode_util:casefold(CPs0) of
+ [Char|CPs] -> append(Char, casefold_list(CPs));
+ [] -> []
+ end.
+
+casefold_bin(CPs0, Acc) ->
+ case unicode_util:casefold(CPs0) of
+ [Char|CPs] when is_integer(Char) ->
+ casefold_bin(CPs, <<Acc/binary, Char/utf8>>);
+ [Chars|CPs] ->
+ casefold_bin(CPs, <<Acc/binary,
+ << <<CP/utf8>> || CP <- Chars>>/binary >>);
+ [] -> Acc
+ end.
+
+
+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, {GCs, _, _}=Sep) when is_list(Str) ->
+ case unicode_util:gc(Str) of
+ [C|Cs] ->
+ case lists:member(C, GCs) 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.
+
+trim_t([Bin|Cont0], N, Sep) when is_binary(Bin) ->
+ <<_:N/binary, Rest/binary>> = Bin,
+ case bin_search(Rest, Cont0, Sep) of
+ {nomatch,_} ->
+ stack(Bin, trim_t(Cont0, 0, Sep));
+ [SepStart|Cont1] ->
+ case bin_search_inv(SepStart, Cont1, Sep) of
+ {nomatch, Cont} ->
+ Tail = trim_t(Cont, 0, Sep),
+ 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, Sep)
+ end
+ end;
+trim_t(Str, 0, {GCs,CPs,_}=Sep) when is_list(Str) ->
+ case unicode_util:cp(Str) of
+ [CP|Cs] ->
+ case lists:member(CP, CPs) of
+ true ->
+ [GC|Cs1] = unicode_util:gc(Str),
+ case lists:member(GC, GCs) of
+ true ->
+ Tail = trim_t(Cs1, 0, Sep),
+ case is_empty(Tail) of
+ true -> [];
+ false -> append(GC,Tail)
+ end;
+ false ->
+ append(GC,trim_t(Cs1, 0, Sep))
+ end;
+ false ->
+ append(CP,trim_t(Cs, 0, Sep))
+ end;
+ [] -> []
+ end;
+trim_t(Bin, N, Sep) when is_binary(Bin) ->
+ <<_:N/binary, Rest/binary>> = Bin,
+ case bin_search(Rest, Sep) of
+ {nomatch,_} -> Bin;
+ [SepStart] ->
+ case bin_search_inv(SepStart, [], Sep) 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, Sep)
+ end
+ end.
+
+take_l([Bin|Cont0], Sep, Acc) when is_binary(Bin) ->
+ case bin_search_inv(Bin, Cont0, Sep) of
+ {nomatch, Cont} ->
+ Used = cp_prefix(Cont0, Cont),
+ take_l(Cont, Sep, [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, {GCs, _, _}=Sep, Acc) when is_list(Str) ->
+ case unicode_util:gc(Str) of
+ [C|Cs] ->
+ case lists:member(C, GCs) of
+ true -> take_l(Cs, Sep, append(rev(C),Acc));
+ false -> {rev(Acc), Str}
+ end;
+ [] -> {rev(Acc), []}
+ end;
+take_l(Bin, Sep, Acc) when is_binary(Bin) ->
+ case bin_search_inv(Bin, [], Sep) 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([Bin|Cont0], Sep, Acc) when is_binary(Bin) ->
+ case bin_search(Bin, Cont0, Sep) of
+ {nomatch, Cont} ->
+ Used = cp_prefix(Cont0, Cont),
+ take_lc(Cont, Sep, [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, _, _}=Sep, Acc) when is_list(Str) ->
+ case unicode_util:gc(Str) of
+ [C|Cs] ->
+ case lists:member(C, GCs) of
+ false -> take_lc(Cs, Sep, append(rev(C),Acc));
+ true -> {rev(Acc), Str}
+ end;
+ [] -> {rev(Acc), []}
+ end;
+take_lc(Bin, Sep, Acc) when is_binary(Bin) ->
+ case bin_search(Bin, [], Sep) 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([Bin|Cont0], N, Sep) when is_binary(Bin) ->
+ <<_:N/binary, Rest/binary>> = Bin,
+ case bin_search(Rest, Cont0, Sep) of
+ {nomatch,Cont} ->
+ Used = cp_prefix(Cont0, Cont),
+ {Head, Tail} = take_t(Cont, 0, Sep),
+ {stack(unicode:characters_to_binary([Bin|Used]), Head), Tail};
+ [SepStart|Cont1] ->
+ case bin_search_inv(SepStart, Cont1, Sep) of
+ {nomatch, Cont} ->
+ {Head, Tail} = take_t(Cont, 0, Sep),
+ Used = cp_prefix(Cont0, Cont),
+ case equal(Tail, Cont) of
+ true ->
+ KeepSz = byte_size(Bin) - byte_size(SepStart),
+ <<Keep:KeepSz/binary, End/binary>> = Bin,
+ {stack(Keep,Head), 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, Sep)
+ end
+ end;
+take_t(Str, 0, {GCs,CPs,_}=Sep) when is_list(Str) ->
+ case unicode_util:cp(Str) of
+ [CP|Cs] ->
+ case lists:member(CP, CPs) of
+ true ->
+ [GC|Cs1] = unicode_util:gc(Str),
+ case lists:member(GC, GCs) of
+ true ->
+ {Head, Tail} = take_t(Cs1, 0, Sep),
+ case equal(Tail, Cs1) of
+ true -> {Head, append(GC,Tail)};
+ false -> {append(GC,Head), Tail}
+ end;
+ false ->
+ {Head, Tail} = take_t(Cs, 0, Sep),
+ {append(CP,Head), Tail}
+ end;
+ false ->
+ {Head, Tail} = take_t(Cs, 0, Sep),
+ {append(CP,Head), Tail}
+ end;
+ [] -> {[],[]}
+ end;
+take_t(Bin, N, Sep) when is_binary(Bin) ->
+ <<_:N/binary, Rest/binary>> = Bin,
+ case bin_search(Rest, Sep) of
+ {nomatch,_} -> {Bin, <<>>};
+ [SepStart] ->
+ case bin_search_inv(SepStart, [], Sep) 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, Sep)
+ end
+ end.
+
+take_tc([Bin|Cont0], N, Sep) when is_binary(Bin) ->
+ <<_:N/binary, Rest/binary>> = Bin,
+ case bin_search_inv(Rest, Cont0, Sep) of
+ {nomatch,Cont} ->
+ Used = cp_prefix(Cont0, Cont),
+ {Head, Tail} = take_tc(Cont, 0, Sep),
+ {stack(unicode:characters_to_binary([Bin|Used]), Head), Tail};
+ [SepStart|Cont1] ->
+ case bin_search(SepStart, Cont1, Sep) of
+ {nomatch, Cont} ->
+ {Head, Tail} = take_tc(Cont, 0, Sep),
+ Used = cp_prefix(Cont0, Cont),
+ case equal(Tail, Cont) of
+ true ->
+ KeepSz = byte_size(Bin) - byte_size(SepStart),
+ <<Keep:KeepSz/binary, End/binary>> = Bin,
+ {stack(Keep,Head), 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, Sep)
+ end
+ end;
+take_tc(Str, 0, {GCs,CPs,_}=Sep) when is_list(Str) ->
+ case unicode_util:cp(Str) of
+ [CP|Cs] ->
+ case lists:member(CP, CPs) of
+ true ->
+ [GC|Cs1] = unicode_util:gc(Str),
+ case lists:member(GC, GCs) of
+ false ->
+ {Head, Tail} = take_tc(Cs1, 0, Sep),
+ case equal(Tail, Cs1) of
+ true -> {Head, append(GC,Tail)};
+ false -> {append(GC,Head), Tail}
+ end;
+ true ->
+ {Head, Tail} = take_tc(Cs1, 0, Sep),
+ {append(GC,Head), Tail}
+ end;
+ false ->
+ {Head, Tail} = take_tc(Cs, 0, Sep),
+ case equal(Tail, Cs) of
+ true -> {Head, append(CP,Tail)};
+ false -> {append(CP,Head), Tail}
+ end
+ end;
+ [] -> {[],[]}
+ end;
+take_tc(Bin, N, Sep) when is_binary(Bin) ->
+ <<_:N/binary, Rest/binary>> = Bin,
+ case bin_search_inv(Rest, [], Sep) of
+ {nomatch,_} -> {Bin, <<>>};
+ [SepStart] ->
+ case bin_search(SepStart, [], Sep) 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, Sep)
+ end
+ end.
+
+prefix_1(Cs, []) -> Cs;
+prefix_1(Cs, [_]=Pre) ->
+ prefix_2(unicode_util:gc(Cs), Pre);
+prefix_1(Cs, Pre) ->
+ prefix_2(unicode_util:cp(Cs), Pre).
+
+prefix_2([C|Cs], [C|Pre]) ->
+ prefix_1(Cs, Pre);
+prefix_2(_, _) ->
+ nomatch.
+
+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([Bin|Cont0], Seps, Ts) when is_binary(Bin) ->
+ case bin_search_inv(Bin, Cont0, Seps) of
+ {nomatch,Cont} ->
+ lexemes_m(Cont, Seps, Ts);
+ Cs ->
+ {Lexeme,Rest} = lexeme_pick(Cs, Seps, []),
+ lexemes_m(Rest, Seps, [Lexeme|Ts])
+ end;
+lexemes_m(Cs0, {GCs, _, _}=Seps, Ts) when is_list(Cs0) ->
+ case unicode_util:gc(Cs0) of
+ [C|Cs] ->
+ case lists:member(C, GCs) of
+ true ->
+ lexemes_m(Cs, Seps, Ts);
+ false ->
+ {Lexeme,Rest} = lexeme_pick(Cs0, Seps, []),
+ lexemes_m(Rest, Seps, [Lexeme|Ts])
+ end;
+ [] ->
+ lists:reverse(Ts)
+ end;
+lexemes_m(Bin, Seps, Ts) when is_binary(Bin) ->
+ case bin_search_inv(Bin, [], Seps) of
+ {nomatch,_} ->
+ lists:reverse(Ts);
+ [Cs] ->
+ {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), Cs0};
+ 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], Seps, N) when is_binary(Bin) ->
+ case bin_search_inv(Bin, Cont0, Seps) of
+ {nomatch,Cont} ->
+ nth_lexeme_m(Cont, Seps, N);
+ Cs when N > 1 ->
+ Rest = lexeme_skip(Cs, Seps),
+ nth_lexeme_m(Rest, Seps, N-1);
+ Cs ->
+ {Lexeme,_} = lexeme_pick(Cs, Seps, []),
+ Lexeme
+ end;
+nth_lexeme_m(Cs0, {GCs, _, _}=Seps, N) when is_list(Cs0) ->
+ case unicode_util:gc(Cs0) of
+ [C|Cs] ->
+ case lists:member(C, GCs) of
+ true ->
+ nth_lexeme_m(Cs, Seps, N);
+ false when N > 1 ->
+ Cs1 = lexeme_skip(Cs, Seps),
+ nth_lexeme_m(Cs1, Seps, N-1);
+ false ->
+ {Lexeme,_} = lexeme_pick(Cs0, Seps, []),
+ Lexeme
+ end;
+ [] ->
+ []
+ end;
+nth_lexeme_m(Bin, Seps, N) when is_binary(Bin) ->
+ case bin_search_inv(Bin, [], Seps) 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 -> Cs0;
+ false -> lexeme_skip(Cs2, Seps)
+ end;
+ false ->
+ lexeme_skip(Cs1, Seps)
+ end;
+lexeme_skip([Bin|Cont0], Seps) when is_binary(Bin) ->
+ case bin_search(Bin, Cont0, Seps) of
+ {nomatch,_} -> lexeme_skip(Cont0, Seps);
+ Cs -> 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 -> Cs0;
+ false -> lexeme_skip(Cs2, Seps)
+ end;
+ false ->
+ lexeme_skip(Cs, Seps)
+ end;
+ [] ->
+ []
+ end;
+lexeme_skip(Bin, Seps) when is_binary(Bin) ->
+ case bin_search(Bin, Seps) of
+ {nomatch,_} -> <<>>;
+ [Left] -> Left
+ 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([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, Seps) ->
+ bin_search(Bin, [], Seps).
+
+bin_search(_Bin, Cont, {[],_,_}) ->
+ {nomatch, Cont};
+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(Seps) ->
+ CPs = search_cp(Seps),
+ Bin = bin_pattern(CPs),
+ {Seps, CPs, Bin}.
+
+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} ->
+ <<_:Where/binary, Cont0/binary>> = Bin,
+ Cont1 = stack(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);
+ BinR when is_binary(BinR), Cont =:= [] ->
+ Next = byte_size(Bin0) - byte_size(BinR),
+ bin_search_loop(Bin0, Next, BinSeps, Cont, Seps);
+ _ ->
+ {nomatch, Cont2}
+ end;
+ true when is_list(Cont1) ->
+ Cont1;
+ true ->
+ [Cont1]
+ end
+ end.
+
+bin_search_inv(Bin, Cont, {[], _, _}) ->
+ [Bin|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([<<>>|CPs], _) ->
+ {nomatch, CPs};
+bin_search_inv_1(CPs = [Bin0|Cont], Sep) when is_binary(Bin0) ->
+ case unicode_util:gc(CPs) of
+ [Sep|Bin] when is_binary(Bin), Cont =:= [] ->
+ bin_search_inv_1([Bin], Sep);
+ [Sep|[Bin|Cont]=Cs] when is_binary(Bin) ->
+ bin_search_inv_1(Cs, Sep);
+ [Sep|Cs] ->
+ {nomatch, Cs};
+ _ -> CPs
+ end.
+
+bin_search_inv_n([<<>>|CPs], _) ->
+ {nomatch, CPs};
+bin_search_inv_n([Bin0|Cont]=CPs, Seps) when is_binary(Bin0) ->
+ [C|Cs0] = unicode_util:gc(CPs),
+ case {lists:member(C, Seps), Cs0} of
+ {true, Cs} when is_binary(Cs), Cont =:= [] ->
+ bin_search_inv_n([Cs], Seps);
+ {true, [Bin|Cont]=Cs} when is_binary(Bin) ->
+ bin_search_inv_n(Cs, Seps);
+ {true, Cs} -> {nomatch, Cs};
+ {false, _} -> CPs
+ end.
+
+bin_search_str(Bin0, Start, Cont, [CP|_]=SearchCPs) ->
+ <<_:Start/binary, Bin/binary>> = Bin0,
+ case binary:match(Bin, <<CP/utf8>>) 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(Bin0, KeepSz, Cont, 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 +1344,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 +1408,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 +1423,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 +1510,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 +1623,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 +1640,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 +1650,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 +1689,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 +1714,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 +1741,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/sys.erl b/lib/stdlib/src/sys.erl
index a6ecf03716..1f966411c5 100644
--- a/lib/stdlib/src/sys.erl
+++ b/lib/stdlib/src/sys.erl
@@ -1,7 +1,7 @@
%%
%% %CopyrightBegin%
%%
-%% Copyright Ericsson AB 1996-2016. 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.
@@ -525,7 +525,7 @@ debug_cmd({log_to_file, false}, Debug) ->
{ok, NDebug};
debug_cmd({log_to_file, FileName}, Debug) ->
NDebug = close_log_file(Debug),
- case file:open(FileName, [write]) of
+ case file:open(FileName, [write,{encoding,utf8}]) of
{ok, Fd} ->
{ok, install_debug(log_to_file, Fd, NDebug)};
_Error ->
@@ -648,7 +648,7 @@ debug_options([{log, N} | T], Debug) when is_integer(N), N > 0 ->
debug_options([statistics | T], Debug) ->
debug_options(T, install_debug(statistics, init_stat(), Debug));
debug_options([{log_to_file, FileName} | T], Debug) ->
- case file:open(FileName, [write]) of
+ case file:open(FileName, [write,{encoding,utf8}]) of
{ok, Fd} ->
debug_options(T, install_debug(log_to_file, Fd, Debug));
_Error ->
diff --git a/lib/stdlib/src/timer.erl b/lib/stdlib/src/timer.erl
index ca868627a9..df10790ea0 100644
--- a/lib/stdlib/src/timer.erl
+++ b/lib/stdlib/src/timer.erl
@@ -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 ->