diff options
Diffstat (limited to 'lib')
61 files changed, 3917 insertions, 514 deletions
diff --git a/lib/crypto/c_src/algorithms.c b/lib/crypto/c_src/algorithms.c index 20707c0531..75cddeb1e9 100644 --- a/lib/crypto/c_src/algorithms.c +++ b/lib/crypto/c_src/algorithms.c @@ -255,29 +255,66 @@ void init_algorithms_types(ErlNifEnv* env) ASSERT(algo_rsa_opts_cnt <= sizeof(algo_rsa_opts)/sizeof(ERL_NIF_TERM)); } -ERL_NIF_TERM algorithms(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) + +ERL_NIF_TERM hash_algorithms(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{ + unsigned int cnt = +#ifdef FIPS_SUPPORT + FIPS_mode() ? algo_hash_fips_cnt : +#endif + algo_hash_cnt; + + return enif_make_list_from_array(env, algo_hash, cnt); +} + +ERL_NIF_TERM pubkey_algorithms(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{ + unsigned int cnt = +#ifdef FIPS_SUPPORT + FIPS_mode() ? algo_pubkey_fips_cnt : +#endif + algo_pubkey_cnt; + + return enif_make_list_from_array(env, algo_pubkey, cnt); +} + + +ERL_NIF_TERM cipher_algorithms(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{ + return cipher_types_as_list(env); /* Exclude old api ciphers */ +} + +ERL_NIF_TERM mac_algorithms(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{ + unsigned int cnt = +#ifdef FIPS_SUPPORT + FIPS_mode() ? algo_mac_fips_cnt : +#endif + algo_mac_cnt; + + return enif_make_list_from_array(env, algo_mac, cnt); +} + + +ERL_NIF_TERM curve_algorithms(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) { + unsigned int cnt = #ifdef FIPS_SUPPORT - int fips_mode = FIPS_mode(); + FIPS_mode() ? algo_curve_fips_cnt : +#endif + algo_curve_cnt; + + return enif_make_list_from_array(env, algo_curve, cnt); +} + + +ERL_NIF_TERM rsa_opts_algorithms(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{ + unsigned int cnt = +#ifdef FIPS_SUPPORT + FIPS_mode() ? algo_rsa_opts_fips_cnt : +#endif + algo_rsa_opts_cnt; - unsigned int hash_cnt = fips_mode ? algo_hash_fips_cnt : algo_hash_cnt; - unsigned int pubkey_cnt = fips_mode ? algo_pubkey_fips_cnt : algo_pubkey_cnt; - unsigned int mac_cnt = fips_mode ? algo_mac_fips_cnt : algo_mac_cnt; - unsigned int curve_cnt = fips_mode ? algo_curve_fips_cnt : algo_curve_cnt; - unsigned int rsa_opts_cnt = fips_mode ? algo_rsa_opts_fips_cnt : algo_rsa_opts_cnt; -#else - unsigned int hash_cnt = algo_hash_cnt; - unsigned int pubkey_cnt = algo_pubkey_cnt; - unsigned int mac_cnt = algo_mac_cnt; - unsigned int curve_cnt = algo_curve_cnt; - unsigned int rsa_opts_cnt = algo_rsa_opts_cnt; -#endif - return enif_make_tuple6(env, - enif_make_list_from_array(env, algo_hash, hash_cnt), - enif_make_list_from_array(env, algo_pubkey, pubkey_cnt), - cipher_types_as_list(env), - enif_make_list_from_array(env, algo_mac, mac_cnt), - enif_make_list_from_array(env, algo_curve, curve_cnt), - enif_make_list_from_array(env, algo_rsa_opts, rsa_opts_cnt) - ); + return enif_make_list_from_array(env, algo_rsa_opts, cnt); } diff --git a/lib/crypto/c_src/algorithms.h b/lib/crypto/c_src/algorithms.h index 068fb661ec..4ad8b56db8 100644 --- a/lib/crypto/c_src/algorithms.h +++ b/lib/crypto/c_src/algorithms.h @@ -25,6 +25,11 @@ void init_algorithms_types(ErlNifEnv* env); -ERL_NIF_TERM algorithms(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +ERL_NIF_TERM hash_algorithms(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +ERL_NIF_TERM pubkey_algorithms(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +ERL_NIF_TERM cipher_algorithms(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +ERL_NIF_TERM mac_algorithms(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +ERL_NIF_TERM curve_algorithms(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +ERL_NIF_TERM rsa_opts_algorithms(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); #endif /* E_ALGORITHMS_H__ */ diff --git a/lib/crypto/c_src/atoms.c b/lib/crypto/c_src/atoms.c index 0793ffa6ca..059c14690f 100644 --- a/lib/crypto/c_src/atoms.c +++ b/lib/crypto/c_src/atoms.c @@ -70,6 +70,7 @@ ERL_NIF_TERM atom_onbasis; ERL_NIF_TERM atom_aes_cfb8; ERL_NIF_TERM atom_aes_cfb128; +ERL_NIF_TERM atom_aes_ige256; #ifdef HAVE_GCM ERL_NIF_TERM atom_aes_gcm; #endif @@ -188,6 +189,7 @@ int init_atoms(ErlNifEnv *env, const ERL_NIF_TERM fips_mode, const ERL_NIF_TERM atom_aes_cfb8 = enif_make_atom(env, "aes_cfb8"); atom_aes_cfb128 = enif_make_atom(env, "aes_cfb128"); + atom_aes_ige256 = enif_make_atom(env, "aes_ige256"); #ifdef HAVE_GCM atom_aes_gcm = enif_make_atom(env, "aes_gcm"); #endif diff --git a/lib/crypto/c_src/atoms.h b/lib/crypto/c_src/atoms.h index 24f6dc26fd..f5913de96f 100644 --- a/lib/crypto/c_src/atoms.h +++ b/lib/crypto/c_src/atoms.h @@ -74,6 +74,7 @@ extern ERL_NIF_TERM atom_onbasis; extern ERL_NIF_TERM atom_aes_cfb8; extern ERL_NIF_TERM atom_aes_cfb128; +extern ERL_NIF_TERM atom_aes_ige256; #ifdef HAVE_GCM extern ERL_NIF_TERM atom_aes_gcm; #endif diff --git a/lib/crypto/c_src/cipher.c b/lib/crypto/c_src/cipher.c index 8f0c93c5db..00072af632 100644 --- a/lib/crypto/c_src/cipher.c +++ b/lib/crypto/c_src/cipher.c @@ -62,34 +62,18 @@ static struct cipher_type_t cipher_types[] = {{"blowfish_ecb"}, {NULL}, 0, 0}, #endif - {{"aes_cbc"}, {&EVP_aes_128_cbc}, 16, 0}, - {{"aes_cbc"}, {&EVP_aes_192_cbc}, 24, 0}, - {{"aes_cbc"}, {&EVP_aes_256_cbc}, 32, 0}, - {{"aes_128_cbc"}, {&EVP_aes_128_cbc}, 16, 0}, {{"aes_192_cbc"}, {&EVP_aes_192_cbc}, 24, 0}, {{"aes_256_cbc"}, {&EVP_aes_256_cbc}, 32, 0}, - {{"aes_cfb8"}, {&EVP_aes_128_cfb8}, 16, NO_FIPS_CIPHER | AES_CFBx}, - {{"aes_cfb8"}, {&EVP_aes_192_cfb8}, 24, NO_FIPS_CIPHER | AES_CFBx}, - {{"aes_cfb8"}, {&EVP_aes_256_cfb8}, 32, NO_FIPS_CIPHER | AES_CFBx}, - {{"aes_128_cfb8"}, {&EVP_aes_128_cfb8}, 16, NO_FIPS_CIPHER | AES_CFBx}, {{"aes_192_cfb8"}, {&EVP_aes_192_cfb8}, 24, NO_FIPS_CIPHER | AES_CFBx}, {{"aes_256_cfb8"}, {&EVP_aes_256_cfb8}, 32, NO_FIPS_CIPHER | AES_CFBx}, - {{"aes_cfb128"}, {&EVP_aes_128_cfb128}, 16, NO_FIPS_CIPHER | AES_CFBx}, - {{"aes_cfb128"}, {&EVP_aes_192_cfb128}, 24, NO_FIPS_CIPHER | AES_CFBx}, - {{"aes_cfb128"}, {&EVP_aes_256_cfb128}, 32, NO_FIPS_CIPHER | AES_CFBx}, - {{"aes_128_cfb128"}, {&EVP_aes_128_cfb128}, 16, NO_FIPS_CIPHER | AES_CFBx}, {{"aes_192_cfb128"}, {&EVP_aes_192_cfb128}, 24, NO_FIPS_CIPHER | AES_CFBx}, {{"aes_256_cfb128"}, {&EVP_aes_256_cfb128}, 32, NO_FIPS_CIPHER | AES_CFBx}, - {{"aes_ecb"}, {&EVP_aes_128_ecb}, 16, ECB_BUG_0_9_8L}, - {{"aes_ecb"}, {&EVP_aes_192_ecb}, 24, ECB_BUG_0_9_8L}, - {{"aes_ecb"}, {&EVP_aes_256_ecb}, 32, ECB_BUG_0_9_8L}, - {{"aes_128_ecb"}, {&EVP_aes_128_ecb}, 16, ECB_BUG_0_9_8L}, {{"aes_192_ecb"}, {&EVP_aes_192_ecb}, 24, ECB_BUG_0_9_8L}, {{"aes_256_ecb"}, {&EVP_aes_256_ecb}, 32, ECB_BUG_0_9_8L}, @@ -98,16 +82,10 @@ static struct cipher_type_t cipher_types[] = {{"aes_128_ctr"}, {&EVP_aes_128_ctr}, 16, 0}, {{"aes_192_ctr"}, {&EVP_aes_192_ctr}, 24, 0}, {{"aes_256_ctr"}, {&EVP_aes_256_ctr}, 32, 0}, - {{"aes_ctr"}, {&EVP_aes_128_ctr}, 16, 0}, - {{"aes_ctr"}, {&EVP_aes_192_ctr}, 24, 0}, - {{"aes_ctr"}, {&EVP_aes_256_ctr}, 32, 0}, #else {{"aes_128_ctr"}, {NULL}, 16, AES_CTR_COMPAT}, {{"aes_192_ctr"}, {NULL}, 24, AES_CTR_COMPAT}, {{"aes_256_ctr"}, {NULL}, 32, AES_CTR_COMPAT}, - {{"aes_ctr"}, {NULL}, 16, AES_CTR_COMPAT}, - {{"aes_ctr"}, {NULL}, 24, AES_CTR_COMPAT}, - {{"aes_ctr"}, {NULL}, 32, AES_CTR_COMPAT}, #endif #if defined(HAVE_CHACHA20) @@ -124,28 +102,20 @@ static struct cipher_type_t cipher_types[] = #endif #if defined(HAVE_GCM) - {{"aes_gcm"}, {&EVP_aes_128_gcm}, 16, AEAD_CIPHER|GCM_MODE, {{EVP_CTRL_GCM_SET_IVLEN,EVP_CTRL_GCM_GET_TAG,EVP_CTRL_GCM_SET_TAG}}}, - {{"aes_gcm"}, {&EVP_aes_192_gcm}, 24, AEAD_CIPHER|GCM_MODE, {{EVP_CTRL_GCM_SET_IVLEN,EVP_CTRL_GCM_GET_TAG,EVP_CTRL_GCM_SET_TAG}}}, - {{"aes_gcm"}, {&EVP_aes_256_gcm}, 32, AEAD_CIPHER|GCM_MODE, {{EVP_CTRL_GCM_SET_IVLEN,EVP_CTRL_GCM_GET_TAG,EVP_CTRL_GCM_SET_TAG}}}, {{"aes_128_gcm"}, {&EVP_aes_128_gcm}, 16, AEAD_CIPHER|GCM_MODE, {{EVP_CTRL_GCM_SET_IVLEN,EVP_CTRL_GCM_GET_TAG,EVP_CTRL_GCM_SET_TAG}}}, {{"aes_192_gcm"}, {&EVP_aes_192_gcm}, 24, AEAD_CIPHER|GCM_MODE, {{EVP_CTRL_GCM_SET_IVLEN,EVP_CTRL_GCM_GET_TAG,EVP_CTRL_GCM_SET_TAG}}}, {{"aes_256_gcm"}, {&EVP_aes_256_gcm}, 32, AEAD_CIPHER|GCM_MODE, {{EVP_CTRL_GCM_SET_IVLEN,EVP_CTRL_GCM_GET_TAG,EVP_CTRL_GCM_SET_TAG}}}, #else - {{"aes_gcm"}, {NULL}, 0, AEAD_CIPHER|GCM_MODE, {{0,0,0}}}, {{"aes_128_gcm"}, {NULL}, 16, AEAD_CIPHER|GCM_MODE, {{0,0,0}}}, {{"aes_192_gcm"}, {NULL}, 24, AEAD_CIPHER|GCM_MODE, {{0,0,0}}}, {{"aes_256_gcm"}, {NULL}, 32, AEAD_CIPHER|GCM_MODE, {{0,0,0}}}, #endif #if defined(HAVE_CCM) - {{"aes_ccm"}, {&EVP_aes_128_ccm}, 16, AEAD_CIPHER|CCM_MODE, {{EVP_CTRL_CCM_SET_IVLEN,EVP_CTRL_CCM_GET_TAG,EVP_CTRL_CCM_SET_TAG}}}, - {{"aes_ccm"}, {&EVP_aes_192_ccm}, 24, AEAD_CIPHER|CCM_MODE, {{EVP_CTRL_CCM_SET_IVLEN,EVP_CTRL_CCM_GET_TAG,EVP_CTRL_CCM_SET_TAG}}}, - {{"aes_ccm"}, {&EVP_aes_256_ccm}, 32, AEAD_CIPHER|CCM_MODE, {{EVP_CTRL_CCM_SET_IVLEN,EVP_CTRL_CCM_GET_TAG,EVP_CTRL_CCM_SET_TAG}}}, {{"aes_128_ccm"}, {&EVP_aes_128_ccm}, 16, AEAD_CIPHER|CCM_MODE, {{EVP_CTRL_CCM_SET_IVLEN,EVP_CTRL_CCM_GET_TAG,EVP_CTRL_CCM_SET_TAG}}}, {{"aes_192_ccm"}, {&EVP_aes_192_ccm}, 24, AEAD_CIPHER|CCM_MODE, {{EVP_CTRL_CCM_SET_IVLEN,EVP_CTRL_CCM_GET_TAG,EVP_CTRL_CCM_SET_TAG}}}, {{"aes_256_ccm"}, {&EVP_aes_256_ccm}, 32, AEAD_CIPHER|CCM_MODE, {{EVP_CTRL_CCM_SET_IVLEN,EVP_CTRL_CCM_GET_TAG,EVP_CTRL_CCM_SET_TAG}}}, #else - {{"aes_ccm"}, {NULL}, 0, AEAD_CIPHER|CCM_MODE, {{0,0,0}}}, {{"aes_128_ccm"}, {NULL}, 16, AEAD_CIPHER|CCM_MODE, {{0,0,0}}}, {{"aes_192_ccm"}, {NULL}, 24, AEAD_CIPHER|CCM_MODE, {{0,0,0}}}, {{"aes_256_ccm"}, {NULL}, 32, AEAD_CIPHER|CCM_MODE, {{0,0,0}}}, @@ -359,13 +329,15 @@ ERL_NIF_TERM cipher_types_as_list(ErlNifEnv* env) prev = atom_undefined; for (p = cipher_types; (p->type.atom & (p->type.atom != atom_false)); p++) { - if ((prev != p->type.atom) && - ((p->cipher.p != NULL) || - (p->flags & (NON_EVP_CIPHER|AES_CTR_COMPAT)) ) && /* Special handling. Bad indeed... */ - ! FORBIDDEN_IN_FIPS(p) - ) - hd = enif_make_list_cell(env, p->type.atom, hd); - prev = p->type.atom; + if ((prev == p->type.atom) || + FORBIDDEN_IN_FIPS(p) ) + continue; + + if ((p->cipher.p != NULL) || + (p->type.atom == atom_aes_ige256)) /* Special handling. Bad indeed... */ + { + hd = enif_make_list_cell(env, p->type.atom, hd); + } } return hd; diff --git a/lib/crypto/c_src/crypto.c b/lib/crypto/c_src/crypto.c index a8014745c8..d533cba140 100644 --- a/lib/crypto/c_src/crypto.c +++ b/lib/crypto/c_src/crypto.c @@ -63,7 +63,12 @@ static ErlNifFunc nif_funcs[] = { {"info_lib", 0, info_lib, 0}, {"info_fips", 0, info_fips, 0}, {"enable_fips_mode", 1, enable_fips_mode, 0}, - {"algorithms", 0, algorithms, 0}, + {"hash_algorithms", 0, hash_algorithms, 0}, + {"pubkey_algorithms", 0, pubkey_algorithms, 0}, + {"cipher_algorithms", 0, cipher_algorithms, 0}, + {"mac_algorithms", 0, mac_algorithms, 0}, + {"curve_algorithms", 0, curve_algorithms, 0}, + {"rsa_opts_algorithms", 0, rsa_opts_algorithms, 0}, {"hash_info", 1, hash_info_nif, 0}, {"hash_nif", 2, hash_nif, 0}, {"hash_init_nif", 1, hash_init_nif, 0}, diff --git a/lib/crypto/src/crypto.erl b/lib/crypto/src/crypto.erl index 3b431cceba..98378412d4 100644 --- a/lib/crypto/src/crypto.erl +++ b/lib/crypto/src/crypto.erl @@ -61,7 +61,8 @@ crypto_one_time/4, crypto_one_time/5, crypto_one_time_aead/6, crypto_one_time_aead/7, crypto_dyn_iv_init/3, - crypto_dyn_iv_update/3 + crypto_dyn_iv_update/3, + supports/1 ]). @@ -499,15 +500,22 @@ stop() -> Macs :: [hmac | cmac | poly1305], Curves :: [ec_named_curve() | edwards_curve_dh() | edwards_curve_ed()], RSAopts :: [rsa_sign_verify_opt() | rsa_opt()] . -supports()-> - {Hashs, PubKeys, Ciphers, Macs, Curves, RsaOpts} = algorithms(), - [{hashs, Hashs}, - {ciphers, prepend_cipher_aliases(Ciphers)}, - {public_keys, PubKeys}, - {macs, Macs}, - {curves, Curves}, - {rsa_opts, RsaOpts} - ]. +supports() -> + [{hashs, hash_algorithms()}, + {ciphers, prepend_old_aliases( cipher_algorithms())}, + {public_keys, pubkey_algorithms()}, + {macs, mac_algorithms()}, + {curves, curve_algorithms()}, + {rsa_opts, rsa_opts_algorithms()} + ]. + +supports(hashs) -> hash_algorithms(); +supports(public_keys) -> pubkey_algorithms(); +supports(ciphers) -> cipher_algorithms(); +supports(macs) -> mac_algorithms(); +supports(curves) -> curve_algorithms(); +supports(rsa_opts) -> rsa_opts_algorithms(). + -spec info_lib() -> [{Name,VerNum,VerStr}] when Name :: binary(), VerNum :: integer(), @@ -700,7 +708,7 @@ poly1305(Key, Data) -> | xts_mode . -%% These ciphers are not available via the EVP interface on older cryptolibs. +%% %% These ciphers are not available via the EVP interface on older cryptolibs. cipher_info(aes_ctr) -> #{block_size => 1,iv_length => 16,key_length => 32,mode => ctr_mode,type => undefined}; cipher_info(aes_128_ctr) -> @@ -709,9 +717,36 @@ cipher_info(aes_192_ctr) -> #{block_size => 1,iv_length => 16,key_length => 24,mode => ctr_mode,type => undefined}; cipher_info(aes_256_ctr) -> #{block_size => 1,iv_length => 16,key_length => 32,mode => ctr_mode,type => undefined}; -%% This cipher is handled specialy. +%% %% This cipher is handled specialy. cipher_info(aes_ige256) -> #{block_size => 16,iv_length => 32,key_length => 16,mode => ige_mode,type => undefined}; +%% %% These ciphers belong to the "old" interface: +%% cipher_info(aes_cbc) -> +%% #{block_size => 16,iv_length => 16,key_length => 24,mode => cbc_mode,type => 423}; +%% cipher_info(aes_cbc128) -> +%% #{block_size => 16,iv_length => 16,key_length => 16,mode => cbc_mode,type => 419}; +%% cipher_info(aes_cbc256) -> +%% #{block_size => 16,iv_length => 16,key_length => 32,mode => cbc_mode,type => 427}; +%% cipher_info(aes_ccm) -> +%% #{block_size => 1,iv_length => 12,key_length => 24,mode => ccm_mode,type => 899}; +%% cipher_info(aes_cfb128) -> +%% #{block_size => 1,iv_length => 16,key_length => 32,mode => cfb_mode,type => 429}; +%% cipher_info(aes_cfb8) -> +%% #{block_size => 1,iv_length => 16,key_length => 32,mode => cfb_mode,type => 429}; +%% cipher_info(aes_ecb) -> +%% #{block_size => 16,iv_length => 0,key_length => 24,mode => ecb_mode,type => 422}; +%% cipher_info(aes_gcm) -> +%% #{block_size => 1,iv_length => 12,key_length => 24,mode => gcm_mode,type => 898}; +%% cipher_info(des3_cbc) -> +%% #{block_size => 8,iv_length => 8,key_length => 24,mode => cbc_mode,type => 44}; +%% cipher_info(des3_cbf) -> +%% #{block_size => 1,iv_length => 8,key_length => 24,mode => cfb_mode,type => 30}; +%% cipher_info(des3_cfb) -> +%% #{block_size => 1,iv_length => 8,key_length => 24,mode => cfb_mode,type => 30}; +%% cipher_info(des_ede3) -> +%% #{block_size => 8,iv_length => 8,key_length => 24,mode => cbc_mode,type => 44}; +%% cipher_info(des_ede3_cbf) -> +%% #{block_size => 1,iv_length => 8,key_length => 24,mode => cfb_mode,type => 30}; cipher_info(Type) -> cipher_info_nif(alias(Type)). @@ -1058,20 +1093,34 @@ ng_crypto_one_time_nif(_Cipher, _Key, _IVec, _Data, _EncryptFlg) -> ?nif_stub. %%%---------------------------------------------------------------- %%% Cipher aliases %%% -prepend_cipher_aliases(L0) -> - L = - case lists:member(des_ede3_cbc, L0) of +-define(if_also(Cipher, Ciphers, AliasCiphers), + case lists:member(Cipher, Ciphers) of true -> - [des3_cbc, des_ede3, des_ede3_cbf, des3_cbf, des3_cfb | L0]; + AliasCiphers; false -> - L0 - end, - case lists:member(aes_128_cbc, L0) of - true -> - [aes_cbc128, aes_cbc256 | L]; - false -> - L - end. + Ciphers + end). + + +prepend_old_aliases(L0) -> + L1 = ?if_also(des_ede3_cbc, L0, + [des3_cbc, des_ede3, des_ede3_cbf, des3_cbf, des3_cfb | L0]), + L2 = ?if_also(aes_128_cbc, L1, + [aes_cbc, aes_cbc128, aes_cbc256 | L1]), + L3 = ?if_also(aes_128_ctr, L2, + [aes_ctr | L2]), + L4 = ?if_also(aes_128_ccm, L3, + [aes_ccm | L3]), + L5 = ?if_also(aes_128_gcm, L4, + [aes_gcm | L4]), + L6 = ?if_also(aes_128_cfb8, L5, + [aes_cfb8 | L5]), + L7 = ?if_also(aes_128_cfb128, L6, + [aes_cfb128 | L6]), + L8 = ?if_also(aes_128_ecb, L7, + [aes_ecb | L7]), + L8. + %%%---- des_ede3_cbc @@ -1088,42 +1137,37 @@ alias(aes_cbc256) -> aes_256_cbc; alias(Alg) -> Alg. -%%%---- des_ede3_cbc -alias(des3_cbc, _) -> des_ede3_cbc; -alias(des_ede3, _) -> des_ede3_cbc; -%%%---- des_ede3_cfb -alias(des_ede3_cbf,_ ) -> des_ede3_cfb; -alias(des3_cbf, _) -> des_ede3_cfb; -alias(des3_cfb, _) -> des_ede3_cfb; -%%%---- aes_*_cbc -alias(aes_cbc128, _) -> aes_128_cbc; -alias(aes_cbc256, _) -> aes_256_cbc; +alias(Ciph, Key) -> alias2(alias(Ciph), Key). + +alias2(aes_cbc, Key) when size(Key)==16 -> aes_128_cbc; +alias2(aes_cbc, Key) when size(Key)==24 -> aes_192_cbc; +alias2(aes_cbc, Key) when size(Key)==32 -> aes_256_cbc; -alias(aes_cbc, Key) when size(Key)==128 -> aes_128_cbc; -alias(aes_cbc, Key) when size(Key)==192 -> aes_192_cbc; -alias(aes_cbc, Key) when size(Key)==256 -> aes_256_cbc; +alias2(aes_cfb8, Key) when size(Key)==16 -> aes_128_cfb8; +alias2(aes_cfb8, Key) when size(Key)==24 -> aes_192_cfb8; +alias2(aes_cfb8, Key) when size(Key)==32 -> aes_256_cfb8; -alias(aes_cfb8, Key) when size(Key)==128 -> aes_128_cfb8; -alias(aes_cfb8, Key) when size(Key)==192 -> aes_192_cfb8; -alias(aes_cfb8, Key) when size(Key)==256 -> aes_256_cfb8; +alias2(aes_cfb128, Key) when size(Key)==16 -> aes_128_cfb128; +alias2(aes_cfb128, Key) when size(Key)==24 -> aes_192_cfb128; +alias2(aes_cfb128, Key) when size(Key)==32 -> aes_256_cfb128; -alias(aes_cfb128, Key) when size(Key)==128 -> aes_128_cfb128; -alias(aes_cfb128, Key) when size(Key)==192 -> aes_192_cfb128; -alias(aes_cfb128, Key) when size(Key)==256 -> aes_256_cfb128; +alias2(aes_ctr, Key) when size(Key)==16 -> aes_128_ctr; +alias2(aes_ctr, Key) when size(Key)==24 -> aes_192_ctr; +alias2(aes_ctr, Key) when size(Key)==32 -> aes_256_ctr; -alias(aes_ctr, Key) when size(Key)==128 -> aes_128_ctr; -alias(aes_ctr, Key) when size(Key)==192 -> aes_192_ctr; -alias(aes_ctr, Key) when size(Key)==256 -> aes_256_ctr; +alias2(aes_ecb, Key) when size(Key)==16 -> aes_128_ecb; +alias2(aes_ecb, Key) when size(Key)==24 -> aes_192_ecb; +alias2(aes_ecb, Key) when size(Key)==32 -> aes_256_ecb; -alias(aes_gcm, Key) when size(Key)==128 -> aes_128_gcm; -alias(aes_gcm, Key) when size(Key)==192 -> aes_192_gcm; -alias(aes_gcm, Key) when size(Key)==256 -> aes_256_gcm; +alias2(aes_gcm, Key) when size(Key)==16 -> aes_128_gcm; +alias2(aes_gcm, Key) when size(Key)==24 -> aes_192_gcm; +alias2(aes_gcm, Key) when size(Key)==32 -> aes_256_gcm; -alias(aes_ccm, Key) when size(Key)==128 -> aes_128_ccm; -alias(aes_ccm, Key) when size(Key)==192 -> aes_192_ccm; -alias(aes_ccm, Key) when size(Key)==256 -> aes_256_ccm; +alias2(aes_ccm, Key) when size(Key)==16 -> aes_128_ccm; +alias2(aes_ccm, Key) when size(Key)==24 -> aes_192_ccm; +alias2(aes_ccm, Key) when size(Key)==32 -> aes_256_ccm; -alias(Alg, _) -> Alg. +alias2(Alg, _) -> Alg. %%%================================================================ %%% @@ -2387,7 +2431,13 @@ exor(Data1, Data2, _Size, MaxByts, Acc) -> do_exor(_A, _B) -> ?nif_stub. -algorithms() -> ?nif_stub. +hash_algorithms() -> ?nif_stub. +pubkey_algorithms() -> ?nif_stub. +cipher_algorithms() -> ?nif_stub. +mac_algorithms() -> ?nif_stub. +curve_algorithms() -> ?nif_stub. +rsa_opts_algorithms() -> ?nif_stub. + int_to_bin(X) when X < 0 -> int_to_bin_neg(X, []); int_to_bin(X) -> int_to_bin_pos(X, []). diff --git a/lib/crypto/test/crypto_SUITE.erl b/lib/crypto/test/crypto_SUITE.erl index 880fd7ab0b..56691223c4 100644 --- a/lib/crypto/test/crypto_SUITE.erl +++ b/lib/crypto/test/crypto_SUITE.erl @@ -116,8 +116,6 @@ groups() -> {group, blowfish_ecb}, {group, blowfish_ofb64}, - {group, aes_cfb128}, - {group, aes_cfb8}, {group, aes_ige256}, {group, des_cbc}, {group, des_cfb}, @@ -125,7 +123,15 @@ groups() -> {group, rc4}, ?NEW_CIPHER_TYPE_SCHEMA, - ?RETIRED_TYPE_ALIASES + {group, aes_128_cfb128}, + {group, aes_192_cfb128}, + {group, aes_256_cfb128}, + {group, aes_128_cfb8}, + {group, aes_192_cfb8}, + {group, aes_256_cfb8}, + ?RETIRED_TYPE_ALIASES, + {group, aes_cfb128}, + {group, aes_cfb8} ]}, {fips, [], [ {group, no_blake2b}, @@ -210,9 +216,15 @@ groups() -> {des_ede3_cbc, [], [block, api_ng, api_ng_one_shot, api_ng_tls]}, {des_ede3_cfb, [], [block, api_ng, api_ng_one_shot, api_ng_tls]}, {rc2_cbc, [], [block, api_ng, api_ng_one_shot, api_ng_tls]}, - {aes_cfb8, [], [block, api_ng, api_ng_one_shot, api_ng_tls]}, + {aes_cfb8, [], [block]}, + {aes_128_cfb8, [], [block, api_ng, api_ng_one_shot, api_ng_tls]}, + {aes_192_cfb8, [], [block, api_ng, api_ng_one_shot, api_ng_tls]}, + {aes_256_cfb8, [], [block, api_ng, api_ng_one_shot, api_ng_tls]}, {no_aes_cfb8, [], [no_support, no_block]}, - {aes_cfb128, [], [block, api_ng, api_ng_one_shot, api_ng_tls]}, + {aes_cfb128, [], [block]}, + {aes_128_cfb128, [], [block, api_ng, api_ng_one_shot, api_ng_tls]}, + {aes_192_cfb128, [], [block, api_ng, api_ng_one_shot, api_ng_tls]}, + {aes_256_cfb128, [], [block, api_ng, api_ng_one_shot, api_ng_tls]}, {no_aes_cfb128, [], [no_support, no_block]}, {aes_ige256, [], [block]}, {no_aes_ige256, [], [no_support, no_block]}, @@ -478,7 +490,7 @@ poly1305(Config) -> %%-------------------------------------------------------------------- no_poly1305() -> [{doc, "Test disabled poly1305 function"}]. -no_poly1305(Config) -> +no_poly1305(_Config) -> Key = <<133,214,190,120,87,85,109,51,127,68,82,254,66,213,6,168,1, 3,128,138,251,13,178,253,74,191,246,175,65,73,245,27>>, Txt = <<"Cryptographic Forum Research Group">>, @@ -889,8 +901,24 @@ cipher_info(Config) when is_list(Config) -> #{type := _,key_length := _,iv_length := _, block_size := _,mode := _} = crypto:cipher_info(aes_128_cbc), {'EXIT',_} = (catch crypto:cipher_info(not_a_cipher)), - lists:foreach(fun(C) -> crypto:cipher_info(C) end, - proplists:get_value(ciphers, crypto:supports())). + case lists:foldl(fun(C,Ok) -> + try crypto:cipher_info(C) + of + _ -> Ok + catch Cls:Exc -> + ct:pal("~p:~p ~p",[Cls,Exc,C]), + false + end + end, + true, +crypto:supports(ciphers)) of +%% proplists:get_value(ciphers, crypto:supports())) of + true -> + ok; + false -> + ct:fail('Cipher unsupported',[]) + end. + %%-------------------------------------------------------------------- hash_info() -> @@ -1553,7 +1581,7 @@ rand_uniform_aux_test(N) -> rand_uniform_aux_test(N-1). crypto_rand_uniform(L,H) -> - R1 = crypto:rand_uniform(L, H), + R1 = (L-1) + rand:uniform(H-L), case (R1 >= L) and (R1 < H) of true -> ok; @@ -2591,6 +2619,22 @@ aes_cfb8(Config) -> "CFB8VarTxt256.rsp", "CFB8VarKey256.rsp", "CFB8GFSbox256.rsp", "CFB8KeySbox256.rsp", "CFB8MMT128.rsp", "CFB8MMT192.rsp", "CFB8MMT256.rsp"]). +aes_128_cfb8(Config) -> + read_rsp(Config, aes_128_cfb8, + ["CFB8VarTxt128.rsp", "CFB8VarKey128.rsp", "CFB8GFSbox128.rsp", "CFB8KeySbox128.rsp", + "CFB8MMT128.rsp"]). + +aes_192_cfb8(Config) -> + read_rsp(Config, aes_192_cfb8, + ["CFB8VarTxt192.rsp", "CFB8VarKey192.rsp", "CFB8GFSbox192.rsp", "CFB8KeySbox192.rsp", + "CFB8MMT192.rsp"]). + +aes_256_cfb8(Config) -> + read_rsp(Config, aes_256_cfb8, + ["CFB8VarTxt256.rsp", "CFB8VarKey256.rsp", "CFB8GFSbox256.rsp", "CFB8KeySbox256.rsp", + "CFB8MMT256.rsp"]). + + aes_cfb128(Config) -> read_rsp(Config, aes_cfb128, ["CFB128VarTxt128.rsp", "CFB128VarKey128.rsp", "CFB128GFSbox128.rsp", "CFB128KeySbox128.rsp", @@ -2598,6 +2642,22 @@ aes_cfb128(Config) -> "CFB128VarTxt256.rsp", "CFB128VarKey256.rsp", "CFB128GFSbox256.rsp", "CFB128KeySbox256.rsp", "CFB128MMT128.rsp", "CFB128MMT192.rsp", "CFB128MMT256.rsp"]). +aes_128_cfb128(Config) -> + read_rsp(Config, aes_128_cfb128, + ["CFB128VarTxt128.rsp", "CFB128VarKey128.rsp", "CFB128GFSbox128.rsp", "CFB128KeySbox128.rsp", + "CFB128MMT128.rsp"]). + +aes_192_cfb128(Config) -> + read_rsp(Config, aes_192_cfb128, + ["CFB128VarTxt192.rsp", "CFB128VarKey192.rsp", "CFB128GFSbox192.rsp", "CFB128KeySbox192.rsp", + "CFB128MMT192.rsp"]). + +aes_256_cfb128(Config) -> + read_rsp(Config, aes_256_cfb128, + ["CFB128VarTxt256.rsp", "CFB128VarKey256.rsp", "CFB128GFSbox256.rsp", "CFB128KeySbox256.rsp", + "CFB128MMT256.rsp"]). + + blowfish_cbc(_) -> [{blowfish_cbc, hexstr2bin("0123456789ABCDEFF0E1D2C3B4A59687"), diff --git a/lib/erl_docgen/src/docgen_edoc_xml_cb.erl b/lib/erl_docgen/src/docgen_edoc_xml_cb.erl index 2c9aa2e3a3..5342d02947 100644 --- a/lib/erl_docgen/src/docgen_edoc_xml_cb.erl +++ b/lib/erl_docgen/src/docgen_edoc_xml_cb.erl @@ -1260,7 +1260,6 @@ get_text(#xmlElement{content=[E]}) -> %% text_and_name_only(Es) -> {N, Ts} text_and_a_name_only(Es) -> - erlang:display(Es), case [Name || #xmlElement{ name = a, attributes = [#xmlAttribute{name=name}]}=Name <- Es] of diff --git a/lib/erl_interface/doc/src/ei.xml b/lib/erl_interface/doc/src/ei.xml index f081ca926a..254ae27cc8 100644 --- a/lib/erl_interface/doc/src/ei.xml +++ b/lib/erl_interface/doc/src/ei.xml @@ -183,6 +183,35 @@ typedef enum { </func> <func> + <name since="OTP @OTP-15712@"><ret>int</ret><nametext>ei_decode_bitstring(const char *buf, int *index, void *p, size_t plen, size_t *bitsp)</nametext></name> + <fsummary>Decode a bitstring.</fsummary> + <desc> + <p>Decodes a bitstring from the binary format.</p> + <taglist> + <tag><c>p</c></tag> + <item><p>Either <c>NULL</c> or points to a buffer where the bytes of the + bitstring will be written.</p> + </item> + <tag><c>plen</c></tag> + <item><p>The max size of the bitstring in <em>bytes</em>, that is the + size of the buffer if <c>p != NULL</c>.</p> + </item> + <tag><c>*bitsp</c></tag> + <item><p>If <c>bitsp</c> is not <c>NULL</c>, set to the actual + number of <em>bits</em> of the bitstring.</p> + </item> + </taglist> + <p>Returns <c>0</c> if it was a bitstring no longer than <c>plen</c> + bytes. The actual length of the bitstring will be + <c>(*bitsp+7)/8</c> bytes. If <c>(*bitsp % 8) > 0</c> only the high + <c>(*bitsp % 8)</c> bits of the last byte are significant.</p> + <p>Number of bits may be divisible by 8, which means a binary + decodable by <c>ei_decode_binary</c> is also decodable by + <c>ei_decode_bitstring</c>.</p> + </desc> + </func> + + <func> <name since=""><ret>int</ret><nametext>ei_decode_boolean(const char *buf, int *index, int *p)</nametext></name> <fsummary>Decode a boolean.</fsummary> <desc> @@ -349,8 +378,10 @@ typedef enum { <c>t</c> is actually an <c>ETERM**</c> (see <seealso marker="erl_eterm"><c>erl_eterm</c></seealso>). The term is later to be deallocated.</p> - <p>Notice that this function is located in the <c>Erl_Interface</c> - library.</p> + <note><p>This function is deprecated as of OTP 22 and will be removed in + OTP 23 together with the old legacy <c>erl_interface</c> library (functions + with prefix <c>erl_</c>).</p> + </note> </desc> </func> @@ -459,6 +490,18 @@ typedef enum { </func> <func> + <name since="OTP @OTP-15712@"><ret>int</ret><nametext>ei_encode_bitstring(char *buf, int *index, const void *p, size_t bits)</nametext></name> + <name since="OTP @OTP-15712@"><ret>int</ret><nametext>ei_x_encode_bitstring(ei_x_buff* x, const void *p, size_t bits)</nametext></name> + <fsummary>Encode a bitstring.</fsummary> + <desc> + <p>Encodes a bitstring in the binary format. The data is at + <c>p</c>. The size of the data is <c>bits</c> bits or + <c>(bits+7)/8</c> bytes. If <c>(bits%8) > 0</c> only the high + <c>(bits%8)</c> bits of the last byte are significant.</p> + </desc> + </func> + + <func> <name since=""><ret>int</ret><nametext>ei_encode_boolean(char *buf, int *index, int p)</nametext></name> <name since=""><ret>int</ret><nametext>ei_x_encode_boolean(ei_x_buff* x, int p)</nametext></name> <fsummary>Encode a boolean.</fsummary> @@ -656,6 +699,10 @@ ei_x_encode_string(&x, "Banana");</pre> <c>erl_interface</c>. Parameter <c>t</c> is actually an <c>ETERM</c> pointer. This function does not free the <c>ETERM</c>.</p> + <note><p>These functions are deprecated as of OTP 22 and will be removed in + OTP 23 together with the old legacy <c>erl_interface</c> library + (functions with prefix <c>erl_</c>).</p> + </note> </desc> </func> <func> @@ -725,12 +772,12 @@ ei_encode_tuple_header(buf, &i, 0);</pre> <name since=""><ret>int</ret><nametext>ei_get_type(const char *buf, const int *index, int *type, int *size)</nametext></name> <fsummary>Fetch the type and size of an encoded term.</fsummary> <desc> - <p>Returns the type in <c>type</c> and size in - <c>size</c> of the encoded term. For strings and atoms, + <p>Returns the type in <c>*type</c> and size in + <c>*size</c> of the encoded term. For strings and atoms, size is the number of characters <em>not</em> including the - terminating <c>NULL</c>. For binaries, <c>size</c> is the number of - bytes. For lists and tuples, <c>size</c> is the arity of - the object. For other types, <c>size</c> is 0. In all + terminating <c>NULL</c>. For binaries and bitstrings, <c>*size</c> is + the number of bytes. For lists, tuples and maps, <c>*size</c> is the + arity of the object. For other types, <c>*size</c> is 0. In all cases, <c>index</c> is left unchanged.</p> </desc> </func> diff --git a/lib/erl_interface/include/ei.h b/lib/erl_interface/include/ei.h index aa2a49098f..591367dc95 100644 --- a/lib/erl_interface/include/ei.h +++ b/lib/erl_interface/include/ei.h @@ -154,11 +154,14 @@ typedef LONG_PTR ssize_t; /* Sigh... */ #define ERL_STRING_EXT 'k' #define ERL_LIST_EXT 'l' #define ERL_BINARY_EXT 'm' +#define ERL_BIT_BINARY_EXT 'M' #define ERL_SMALL_BIG_EXT 'n' #define ERL_LARGE_BIG_EXT 'o' #define ERL_NEW_FUN_EXT 'p' #define ERL_MAP_EXT 't' #define ERL_FUN_EXT 'u' +#define ERL_EXPORT_EXT 'q' + #define ERL_NEW_CACHE 'N' /* c nodes don't know these two */ #define ERL_CACHED_ATOM 'C' @@ -269,15 +272,23 @@ typedef struct { typedef struct { long arity; char module[MAXATOMLEN_UTF8]; - erlang_char_encoding module_org_enc; - char md5[16]; - long index; - long old_index; - long uniq; - long n_free_vars; - erlang_pid pid; - long free_var_len; - char* free_vars; + enum { EI_FUN_CLOSURE, EI_FUN_EXPORT } type; + union { + struct { + char md5[16]; + long index; + long old_index; + long uniq; + long n_free_vars; + erlang_pid pid; + long free_var_len; + char* free_vars; + } closure; + struct { + char* func; + int func_allocated; + } export; + } u; } erlang_fun; /* a big */ @@ -515,7 +526,9 @@ int ei_x_encode_atom_len(ei_x_buff* x, const char* s, int len); int ei_x_encode_atom_len_as(ei_x_buff* x, const char* s, int len, erlang_char_encoding from, erlang_char_encoding to); int ei_encode_binary(char *buf, int *index, const void *p, long len); +int ei_encode_bitstring(char *buf, int *index, const void *p, size_t bits); int ei_x_encode_binary(ei_x_buff* x, const void* s, int len); +int ei_x_encode_bitstring(ei_x_buff* x, const void* p, size_t bits); int ei_encode_pid(char *buf, int *index, const erlang_pid *p); int ei_x_encode_pid(ei_x_buff* x, const erlang_pid* pid); int ei_encode_fun(char* buf, int* index, const erlang_fun* p); @@ -524,8 +537,8 @@ int ei_encode_port(char *buf, int *index, const erlang_port *p); int ei_x_encode_port(ei_x_buff* x, const erlang_port *p); int ei_encode_ref(char *buf, int *index, const erlang_ref *p); int ei_x_encode_ref(ei_x_buff* x, const erlang_ref *p); -int ei_encode_term(char *buf, int *index, void *t); /* ETERM* actually */ -int ei_x_encode_term(ei_x_buff* x, void* t); +int ei_encode_term(char *buf, int *index, void *t) EI_DEPRECATED_ATTR; +int ei_x_encode_term(ei_x_buff* x, void* t) EI_DEPRECATED_ATTR; int ei_encode_trace(char *buf, int *index, const erlang_trace *p); int ei_x_encode_trace(ei_x_buff* x, const erlang_trace *p); int ei_encode_tuple_header(char *buf, int *index, int arity); @@ -547,8 +560,6 @@ int ei_x_encode_map_header(ei_x_buff* x, long n); */ int ei_get_type(const char *buf, const int *index, int *type, int *size); -int ei_get_type_internal(const char *buf, const int *index, int *type, - int *size); /* Step through buffer, decoding the given type into the buffer * provided. On success, 0 is returned and index is updated to point @@ -567,12 +578,13 @@ int ei_decode_string(const char *buf, int *index, char *p); int ei_decode_atom(const char *buf, int *index, char *p); int ei_decode_atom_as(const char *buf, int *index, char *p, int destlen, erlang_char_encoding want, erlang_char_encoding* was, erlang_char_encoding* result); int ei_decode_binary(const char *buf, int *index, void *p, long *len); +int ei_decode_bitstring(const char *buf, int *index, void *p, size_t plen, size_t *bitsp); int ei_decode_fun(const char* buf, int* index, erlang_fun* p); void free_fun(erlang_fun* f); int ei_decode_pid(const char *buf, int *index, erlang_pid *p); int ei_decode_port(const char *buf, int *index, erlang_port *p); int ei_decode_ref(const char *buf, int *index, erlang_ref *p); -int ei_decode_term(const char *buf, int *index, void *t); /* ETERM** actually */ +int ei_decode_term(const char *buf, int *index, void *t) EI_DEPRECATED_ATTR; int ei_decode_trace(const char *buf, int *index, erlang_trace *p); int ei_decode_tuple_header(const char *buf, int *index, int *arity); int ei_decode_list_header(const char *buf, int *index, int *arity); diff --git a/lib/erl_interface/src/connect/ei_connect.c b/lib/erl_interface/src/connect/ei_connect.c index 7a304e6d4f..0cbad235cc 100644 --- a/lib/erl_interface/src/connect/ei_connect.c +++ b/lib/erl_interface/src/connect/ei_connect.c @@ -1846,6 +1846,7 @@ static int send_name_or_challenge(ei_socket_callbacks *cbs, const char* function[] = {"SEND_NAME", "SEND_CHALLENGE"}; int err; ssize_t len; + unsigned int flags; if (f_chall) siz += 4; @@ -1867,7 +1868,7 @@ static int send_name_or_challenge(ei_socket_callbacks *cbs, } put8(s, 'n'); put16be(s, version); - put32be(s, (DFLAG_EXTENDED_REFERENCES + flags = (DFLAG_EXTENDED_REFERENCES | DFLAG_DIST_MONITOR | DFLAG_EXTENDED_PIDS_PORTS | DFLAG_FUN_TAGS @@ -1876,7 +1877,14 @@ static int send_name_or_challenge(ei_socket_callbacks *cbs, | DFLAG_SMALL_ATOM_TAGS | DFLAG_UTF8_ATOMS | DFLAG_MAP_TAG - | DFLAG_BIG_CREATION)); + | DFLAG_BIG_CREATION + | DFLAG_EXPORT_PTR_TAG + | DFLAG_BIT_BINARIES); + if (ei_internal_use_21_bitstr_expfun()) { + flags &= ~(DFLAG_EXPORT_PTR_TAG + | DFLAG_BIT_BINARIES); + } + put32be(s, flags); if (f_chall) put32be(s, challenge); memcpy(s, nodename, strlen(nodename)); @@ -1941,8 +1949,7 @@ static int recv_challenge(ei_socket_callbacks *cbs, void *ctx, goto error; } - if (!(*flags & DFLAG_EXTENDED_PIDS_PORTS) - && !ei_internal_use_r9_pids_ports()) { + if (!(*flags & DFLAG_EXTENDED_PIDS_PORTS)) { EI_TRACE_ERR0("recv_challenge","<- RECV_CHALLENGE peer cannot " "handle extended pids and ports"); erl_errno = EIO; @@ -2236,8 +2243,7 @@ static int recv_name(ei_socket_callbacks *cbs, void *ctx, goto error; } - if (!(*flags & DFLAG_EXTENDED_PIDS_PORTS) - && !ei_internal_use_r9_pids_ports()) { + if (!(*flags & DFLAG_EXTENDED_PIDS_PORTS)) { EI_TRACE_ERR0("recv_name","<- RECV_NAME peer cannot " "handle extended pids and ports"); erl_errno = EIO; diff --git a/lib/erl_interface/src/connect/ei_connect_int.h b/lib/erl_interface/src/connect/ei_connect_int.h index 0bcccaa84b..b41a5f2b23 100644 --- a/lib/erl_interface/src/connect/ei_connect_int.h +++ b/lib/erl_interface/src/connect/ei_connect_int.h @@ -102,6 +102,8 @@ extern int h_errno; #define DFLAG_FUN_TAGS 16 #define DFLAG_NEW_FUN_TAGS 0x80 #define DFLAG_EXTENDED_PIDS_PORTS 0x100 +#define DFLAG_EXPORT_PTR_TAG 0x200 +#define DFLAG_BIT_BINARIES 0x400 #define DFLAG_NEW_FLOATS 0x800 #define DFLAG_SMALL_ATOM_TAGS 0x4000 #define DFLAG_UTF8_ATOMS 0x10000 diff --git a/lib/erl_interface/src/decode/decode_binary.c b/lib/erl_interface/src/decode/decode_binary.c index 5b8d234984..2799438bef 100644 --- a/lib/erl_interface/src/decode/decode_binary.c +++ b/lib/erl_interface/src/decode/decode_binary.c @@ -40,4 +40,40 @@ int ei_decode_binary(const char *buf, int *index, void *p, long *lenp) return 0; } +int ei_decode_bitstring(const char *buf, int *index, void *p, size_t plen, + size_t *bitsp) +{ + const char *s = buf + *index; + const char *s0 = s; + unsigned long len; + unsigned char last_bits; + const unsigned char tag = get8(s); + + if (tag == ERL_BINARY_EXT) { + long bytes; + int ret = ei_decode_binary(buf, index, p, &bytes); + if (bitsp) + *bitsp = (size_t)bytes * 8; + return ret; + } + + if (tag != ERL_BIT_BINARY_EXT) + return -1; + + len = get32be(s); + last_bits = get8(s); + + if (len > plen || ((last_bits==0) != (len==0)) || last_bits > 8) + return -1; + + if (p) + memcpy(p, s, len); + s += len; + + if (bitsp) + *bitsp = (len == 0) ? 0 : ((len-1) * 8) + last_bits; + + *index += s-s0; + return 0; +} diff --git a/lib/erl_interface/src/decode/decode_fun.c b/lib/erl_interface/src/decode/decode_fun.c index f944c028af..32a950433e 100644 --- a/lib/erl_interface/src/decode/decode_fun.c +++ b/lib/erl_interface/src/decode/decode_fun.c @@ -33,22 +33,20 @@ int ei_decode_fun(const char *buf, int *index, erlang_fun *p) int i, ix, ix0, n; erlang_pid* p_pid; char* p_module; - erlang_char_encoding* p_module_org_enc; long* p_index; long* p_uniq; long* p_old_index; if (p != NULL) { - p_pid = &p->pid; + p_pid = &p->u.closure.pid; p_module = &p->module[0]; - p_module_org_enc = &p->module_org_enc; - p_index = &p->index; - p_uniq = &p->uniq; - p_old_index = &p->old_index; + p_index = &p->u.closure.index; + p_uniq = &p->u.closure.uniq; + p_old_index = &p->u.closure.old_index; } else { - p_pid = NULL; p_module = NULL; p_module_org_enc = NULL; p_index = NULL; p_uniq = NULL; p_old_index = NULL; + p_pid = NULL; p_module = NULL; } switch (get8(s)) { @@ -63,7 +61,7 @@ int ei_decode_fun(const char *buf, int *index, erlang_fun *p) return -1; /* then the module (atom) */ if (ei_decode_atom_as(s, &ix, p_module, MAXATOMLEN_UTF8, ERLANG_UTF8, - p_module_org_enc, NULL) < 0) + NULL, NULL) < 0) return -1; /* then the index */ if (ei_decode_long(s, &ix, p_index) < 0) @@ -78,11 +76,11 @@ int ei_decode_fun(const char *buf, int *index, erlang_fun *p) return -1; } if (p != NULL) { - p->n_free_vars = n; - p->free_var_len = ix - ix0; - p->free_vars = ei_malloc(ix - ix0); - if (!(p->free_vars)) return -1; - memcpy(p->free_vars, s + ix0, ix - ix0); + p->u.closure.n_free_vars = n; + p->u.closure.free_var_len = ix - ix0; + p->u.closure.free_vars = ei_malloc(ix - ix0); + if (!(p->u.closure.free_vars)) return -1; + memcpy(p->u.closure.free_vars, s + ix0, ix - ix0); } s += ix; *index += s-s0; @@ -93,20 +91,23 @@ int ei_decode_fun(const char *buf, int *index, erlang_fun *p) n = get32be(s); /* then the arity */ i = get8(s); - if (p != NULL) p->arity = i; - /* then md5 */ - if (p != NULL) memcpy(p->md5, s, 16); + if (p != NULL) { + p->type = EI_FUN_CLOSURE; + p->arity = i; + /* then md5 */ + memcpy(p->u.closure.md5, s, 16); + } s += 16; /* then index */ i = get32be(s); - if (p != NULL) p->index = i; + if (p != NULL) p->u.closure.index = i; /* then the number of free vars (environment) */ i = get32be(s); - if (p != NULL) p->n_free_vars = i; + if (p != NULL) p->u.closure.n_free_vars = i; /* then the module (atom) */ ix = 0; if (ei_decode_atom_as(s, &ix, p_module, MAXATOMLEN_UTF8, ERLANG_UTF8, - p_module_org_enc, NULL) < 0) + NULL, NULL) < 0) return -1; /* then the old_index */ if (ei_decode_long(s, &ix, p_old_index) < 0) @@ -122,17 +123,56 @@ int ei_decode_fun(const char *buf, int *index, erlang_fun *p) n = n - (s - s0) + 1; if (n < 0) return -1; if (p != NULL) { - p->free_var_len = n; + p->u.closure.free_var_len = n; if (n > 0) { - p->free_vars = malloc(n); - if (!(p->free_vars)) return -1; - memcpy(p->free_vars, s, n); + p->u.closure.free_vars = malloc(n); + if (!(p->u.closure.free_vars)) return -1; + memcpy(p->u.closure.free_vars, s, n); } } s += n; *index += s-s0; return 0; break; + case ERL_EXPORT_EXT: { + char* p_func; + long* p_arity; + int used; + + if (p) { + p->type = EI_FUN_EXPORT; + p_arity = &p->arity; + } + else { + p_arity = NULL; + } + if (ei_decode_atom_as(s, &ix, p_module, MAXATOMLEN_UTF8, ERLANG_UTF8, + NULL, NULL) < 0) + return -1; + if (p) { + /* try use module buffer for function name */ + used = strlen(p->module) + 1; + p_func = p->module + used; + p->u.export.func = p_func; + p->u.export.func_allocated = 0; + } + else { + used = 0; + p_func = NULL; + } + while (ei_decode_atom_as(s, &ix, p_func, MAXATOMLEN_UTF8-used, + ERLANG_UTF8, NULL, NULL) < 0) { + if (!used) + return -1; + p_func = malloc(MAXATOMLEN_UTF8); + p->u.export.func = p_func; + p->u.export.func_allocated = 1; + used = 0; + } + if (ei_decode_long(s, &ix, p_arity) < 0) + return -1; + return 0; + } default: return -1; } @@ -140,6 +180,14 @@ int ei_decode_fun(const char *buf, int *index, erlang_fun *p) void free_fun(erlang_fun* f) { - if (f->free_var_len > 0) - ei_free(f->free_vars); + switch (f->type) { + case EI_FUN_CLOSURE: + if (f->u.closure.free_var_len > 0) + ei_free(f->u.closure.free_vars); + break; + case EI_FUN_EXPORT: + if (f->u.export.func_allocated) + ei_free(f->u.export.func); + break; + } } diff --git a/lib/erl_interface/src/decode/decode_skip.c b/lib/erl_interface/src/decode/decode_skip.c index 0db315f09b..11d3bc1786 100644 --- a/lib/erl_interface/src/decode/decode_skip.c +++ b/lib/erl_interface/src/decode/decode_skip.c @@ -21,13 +21,21 @@ #include "eiext.h" #include "decode_skip.h" +#ifdef HAVE_STDINT_H +# include <stdint.h> +#endif + +#ifndef SIZE_MAX +# define SIZE_MAX (~((size_t)0)) +#endif + int ei_skip_term(const char* buf, int* index) { int i, n, ty; /* ASSERT(ep != NULL); */ - ei_get_type_internal(buf, index, &ty, &n); + ei_get_type(buf, index, &ty, &n); switch (ty) { case ERL_ATOM_EXT: /* FIXME: what if some weird locale is in use? */ @@ -54,7 +62,7 @@ int ei_skip_term(const char* buf, int* index) if (ei_decode_list_header(buf, index, &n) < 0) return -1; for (i = 0; i < n; ++i) ei_skip_term(buf, index); - if (ei_get_type_internal(buf, index, &ty, &n) < 0) return -1; + if (ei_get_type(buf, index, &ty, &n) < 0) return -1; if (ty != ERL_NIL_EXT) ei_skip_term(buf, index); else @@ -79,6 +87,10 @@ int ei_skip_term(const char* buf, int* index) if (ei_decode_binary(buf, index, NULL, NULL) < 0) return -1; break; + case ERL_BIT_BINARY_EXT: + if (ei_decode_bitstring(buf, index, NULL, SIZE_MAX, NULL) < 0) + return -1; + break; case ERL_SMALL_INTEGER_EXT: case ERL_INTEGER_EXT: if (ei_decode_long(buf, index, NULL) < 0) return -1; diff --git a/lib/erl_interface/src/encode/encode_binary.c b/lib/erl_interface/src/encode/encode_binary.c index 4471c51769..4aa9f6bc16 100644 --- a/lib/erl_interface/src/encode/encode_binary.c +++ b/lib/erl_interface/src/encode/encode_binary.c @@ -40,3 +40,27 @@ int ei_encode_binary(char *buf, int *index, const void *p, long len) return 0; } +int ei_encode_bitstring(char *buf, int *index, const void *p, size_t bits) +{ + char *s = buf + *index; + char *s0 = s; + size_t bytes = (bits + 7) / 8; + char last_bits = bits % 8; + + if (bytes == 0 || last_bits == 0) + return ei_encode_binary(buf, index, p, bytes); + + if (!buf) s += 6; + else { + put8(s, ERL_BIT_BINARY_EXT); + put32be(s, bytes); + put8(s, last_bits); + memcpy(s, p, bytes); + s[bytes-1] &= (0xff << (8-last_bits)); + } + s += bytes; + + *index += s-s0; + + return 0; +} diff --git a/lib/erl_interface/src/encode/encode_fun.c b/lib/erl_interface/src/encode/encode_fun.c index 3bfc7530d1..38ba7c5b30 100644 --- a/lib/erl_interface/src/encode/encode_fun.c +++ b/lib/erl_interface/src/encode/encode_fun.c @@ -26,56 +26,72 @@ int ei_encode_fun(char *buf, int *index, const erlang_fun *p) { int ix = *index; - if (p->arity == -1) { - /* ERL_FUN_EXT */ - if (buf != NULL) { - char* s = buf + ix; - put8(s, ERL_FUN_EXT); - put32be(s, p->n_free_vars); - } - ix += sizeof(char) + 4; - if (ei_encode_pid(buf, &ix, &p->pid) < 0) - return -1; - if (ei_encode_atom_as(buf, &ix, p->module, ERLANG_UTF8, p->module_org_enc) < 0) - return -1; - if (ei_encode_long(buf, &ix, p->index) < 0) - return -1; - if (ei_encode_long(buf, &ix, p->uniq) < 0) - return -1; - if (buf != NULL) - memcpy(buf + ix, p->free_vars, p->free_var_len); - ix += p->free_var_len; - } else { - char *size_p; - /* ERL_NEW_FUN_EXT */ - if (buf != NULL) { - char* s = buf + ix; - put8(s, ERL_NEW_FUN_EXT); - size_p = s; - s += 4; - put8(s, p->arity); - memcpy(s, p->md5, sizeof(p->md5)); - s += sizeof(p->md5); - put32be(s, p->index); - put32be(s, p->n_free_vars); - } else - size_p = NULL; - ix += 1 + 4 + 1 + sizeof(p->md5) + 4 + 4; - if (ei_encode_atom_as(buf, &ix, p->module, ERLANG_UTF8, p->module_org_enc) < 0) - return -1; - if (ei_encode_long(buf, &ix, p->old_index) < 0) - return -1; - if (ei_encode_long(buf, &ix, p->uniq) < 0) - return -1; - if (ei_encode_pid(buf, &ix, &p->pid) < 0) - return -1; - if (buf != NULL) - memcpy(buf + ix, p->free_vars, p->free_var_len); - ix += p->free_var_len; - if (size_p != NULL) { - int sz = buf + ix - size_p; - put32be(size_p, sz); + switch (p->type) { + case EI_FUN_CLOSURE: + if (p->arity == -1) { + /* ERL_FUN_EXT */ + if (buf != NULL) { + char* s = buf + ix; + put8(s, ERL_FUN_EXT); + put32be(s, p->u.closure.n_free_vars); + } + ix += sizeof(char) + 4; + if (ei_encode_pid(buf, &ix, &p->u.closure.pid) < 0) + return -1; + if (ei_encode_atom_as(buf, &ix, p->module, ERLANG_UTF8, ERLANG_UTF8) < 0) + return -1; + if (ei_encode_long(buf, &ix, p->u.closure.index) < 0) + return -1; + if (ei_encode_long(buf, &ix, p->u.closure.uniq) < 0) + return -1; + if (buf != NULL) + memcpy(buf + ix, p->u.closure.free_vars, p->u.closure.free_var_len); + ix += p->u.closure.free_var_len; + } else { + char *size_p; + if (buf != NULL) { + char* s = buf + ix; + put8(s, ERL_NEW_FUN_EXT); + size_p = s; + s += 4; + put8(s, p->arity); + memcpy(s, p->u.closure.md5, sizeof(p->u.closure.md5)); + s += sizeof(p->u.closure.md5); + put32be(s, p->u.closure.index); + put32be(s, p->u.closure.n_free_vars); + } else + size_p = NULL; + ix += 1 + 4 + 1 + sizeof(p->u.closure.md5) + 4 + 4; + if (ei_encode_atom_as(buf, &ix, p->module, ERLANG_UTF8, ERLANG_UTF8) < 0) + return -1; + if (ei_encode_long(buf, &ix, p->u.closure.old_index) < 0) + return -1; + if (ei_encode_long(buf, &ix, p->u.closure.uniq) < 0) + return -1; + if (ei_encode_pid(buf, &ix, &p->u.closure.pid) < 0) + return -1; + if (buf != NULL) + memcpy(buf + ix, p->u.closure.free_vars, p->u.closure.free_var_len); + ix += p->u.closure.free_var_len; + if (size_p != NULL) { + int sz = buf + ix - size_p; + put32be(size_p, sz); + } } + break; + case EI_FUN_EXPORT: + if (buf != NULL) { + char* s = buf + ix; + put8(s, ERL_EXPORT_EXT); + } + ix++; + if (ei_encode_atom_as(buf, &ix, p->module, ERLANG_UTF8, ERLANG_UTF8) < 0) + return -1; + if (ei_encode_atom_as(buf, &ix, p->u.export.func, ERLANG_UTF8, ERLANG_UTF8) < 0) + return -1; + if (ei_encode_long(buf, &ix, p->arity) < 0) + return -1; + break; } *index = ix; return 0; diff --git a/lib/erl_interface/src/legacy/erl_eterm.c b/lib/erl_interface/src/legacy/erl_eterm.c index 7ed2bdbc93..7ecea83b1a 100644 --- a/lib/erl_interface/src/legacy/erl_eterm.c +++ b/lib/erl_interface/src/legacy/erl_eterm.c @@ -299,12 +299,7 @@ void erl_mk_pid_helper(ETERM *ep, unsigned int number, unsigned int serial, unsigned int creation) { ERL_PID_NUMBER(ep) = number & 0x7fff; /* 15 bits */ - if (ei_internal_use_r9_pids_ports()) { - ERL_PID_SERIAL(ep) = serial & 0x07; /* 3 bits */ - } - else { - ERL_PID_SERIAL(ep) = serial & 0x1fff; /* 13 bits */ - } + ERL_PID_SERIAL(ep) = serial & 0x1fff; /* 13 bits */ ERL_PID_CREATION(ep) = creation; /* 32 bits */ } @@ -334,12 +329,7 @@ ETERM *erl_mk_port(const char *node, void erl_mk_port_helper(ETERM* ep, unsigned number, unsigned int creation) { - if (ei_internal_use_r9_pids_ports()) { - ERL_PORT_NUMBER(ep) = number & 0x3ffff; /* 18 bits */ - } - else { - ERL_PORT_NUMBER(ep) = number & 0x0fffffff; /* 18 bits */ - } + ERL_PORT_NUMBER(ep) = number & 0x0fffffff; /* 18 bits */ ERL_PORT_CREATION(ep) = creation; /* 32 bits */ } diff --git a/lib/erl_interface/src/misc/ei_compat.c b/lib/erl_interface/src/misc/ei_compat.c index 93d7dbfb83..787895992e 100644 --- a/lib/erl_interface/src/misc/ei_compat.c +++ b/lib/erl_interface/src/misc/ei_compat.c @@ -22,19 +22,22 @@ #include "ei.h" #include "ei_internal.h" -#define EI_COMPAT_NO_REL (~((unsigned) 0)) +#include <limits.h> -static unsigned compat_rel = EI_COMPAT_NO_REL; +#ifndef EI_COMPAT +# define EI_COMPAT UINT_MAX +#endif + +static unsigned compat_rel = EI_COMPAT; void ei_set_compat_rel(unsigned rel) { - if (compat_rel == EI_COMPAT_NO_REL) - compat_rel = rel; + compat_rel = rel; } -int -ei_internal_use_r9_pids_ports(void) +int ei_internal_use_21_bitstr_expfun(void) { - return compat_rel < 10; + return compat_rel < 22; } + diff --git a/lib/erl_interface/src/misc/ei_decode_term.c b/lib/erl_interface/src/misc/ei_decode_term.c index 63a7034508..8a4f7cc30d 100644 --- a/lib/erl_interface/src/misc/ei_decode_term.c +++ b/lib/erl_interface/src/misc/ei_decode_term.c @@ -87,6 +87,14 @@ int ei_decode_ei_term(const char* buf, int* index, ei_term* term) case ERL_BINARY_EXT: term->size = get32be(s); return 0; + case ERL_BIT_BINARY_EXT: { + int bytes = get32be(s); + int last_bits = get8(s); + if (((last_bits==0) != (bytes==0)) || last_bits > 8) + return -1; + term->size = bytes; + return 0; + } case ERL_SMALL_BIG_EXT: if ((term->arity = get8(s)) != 4) return -1; sign = get8(s); diff --git a/lib/erl_interface/src/misc/ei_internal.h b/lib/erl_interface/src/misc/ei_internal.h index f28dd6d668..ab12597c86 100644 --- a/lib/erl_interface/src/misc/ei_internal.h +++ b/lib/erl_interface/src/misc/ei_internal.h @@ -157,7 +157,7 @@ int ei_init_connect(void); void ei_trace_printf(const char *name, int level, const char *format, ...); -int ei_internal_use_r9_pids_ports(void); +int ei_internal_use_21_bitstr_expfun(void); int ei_get_cbs_ctx__(ei_socket_callbacks **cbs, void **ctx, int fd); diff --git a/lib/erl_interface/src/misc/ei_printterm.c b/lib/erl_interface/src/misc/ei_printterm.c index 058de00de5..a89b990ac1 100644 --- a/lib/erl_interface/src/misc/ei_printterm.c +++ b/lib/erl_interface/src/misc/ei_printterm.c @@ -131,7 +131,7 @@ static int print_term(FILE* fp, ei_x_buff* x, if (fp == NULL && x == NULL) return -1; doquote = 0; - ei_get_type_internal(buf, index, &ty, &n); + ei_get_type(buf, index, &ty, &n); switch (ty) { case ERL_ATOM_EXT: case ERL_ATOM_UTF8_EXT: @@ -189,7 +189,7 @@ static int print_term(FILE* fp, ei_x_buff* x, xputs(", ", fp, x); ch_written += 2; } } - if (ei_get_type_internal(buf, &tindex, &ty, &n) < 0) goto err; + if (ei_get_type(buf, &tindex, &ty, &n) < 0) goto err; if (ty != ERL_NIL_EXT) { xputs(" | ", fp, x); ch_written += 3; r = print_term(fp, x, buf, &tindex); @@ -249,6 +249,34 @@ static int print_term(FILE* fp, ei_x_buff* x, xputc('>', fp, x); ++ch_written; ei_free(p); break; + case ERL_BIT_BINARY_EXT: { + size_t bits; + int trunc = 0; + p = ei_malloc(n); + if (p == NULL) goto err; + if (ei_decode_bitstring(buf, index, p, n, &bits) < 0) { + ei_free(p); + goto err; + } + ch_written += xprintf(fp, x, "#Bits<"); + m = (bits+7) / 8; + if (m > BINPRINTSIZE) { + m = BINPRINTSIZE; + trunc = 1; + } + --m; + for (i = 0; i < m; ++i) { + ch_written += xprintf(fp, x, "%d,", p[i]); + } + ch_written += xprintf(fp, x, "%d", p[i]); + if (trunc) + ch_written += xprintf(fp, x, ",..."); + else if (bits % 8 != 0) + ch_written += xprintf(fp, x, ":%u", (unsigned)(bits % 8)); + xputc('>', fp, x); ++ch_written; + ei_free(p); + break; + } case ERL_SMALL_INTEGER_EXT: case ERL_INTEGER_EXT: if (ei_decode_long(buf, index, &l) < 0) goto err; diff --git a/lib/erl_interface/src/misc/ei_x_encode.c b/lib/erl_interface/src/misc/ei_x_encode.c index 4ff5974663..2da271795f 100644 --- a/lib/erl_interface/src/misc/ei_x_encode.c +++ b/lib/erl_interface/src/misc/ei_x_encode.c @@ -117,6 +117,16 @@ int ei_x_encode_binary(ei_x_buff* x, const void* p, int len) return ei_encode_binary(x->buff, &x->index, p, len); } +int ei_x_encode_bitstring(ei_x_buff* x, const void* p, size_t bits) +{ + int i = x->index; + if (ei_encode_bitstring(NULL, &i, p, bits) == -1) + return -1; + if (!x_fix_buff(x, i)) + return -1; + return ei_encode_bitstring(x->buff, &x->index, p, bits); +} + int ei_x_encode_long(ei_x_buff* x, long n) { int i = x->index; diff --git a/lib/erl_interface/src/misc/get_type.c b/lib/erl_interface/src/misc/get_type.c index aa69cd4d60..eef58a9363 100644 --- a/lib/erl_interface/src/misc/get_type.c +++ b/lib/erl_interface/src/misc/get_type.c @@ -27,17 +27,8 @@ /* for types with meaningful length attributes, return the length too. In other cases, return length 0 */ -/* FIXME working on this one.... */ - int ei_get_type(const char *buf, const int *index, int *type, int *len) { - return ei_get_type_internal(buf, index, type, len); -} - - -int ei_get_type_internal(const char *buf, const int *index, - int *type, int *len) -{ const char *s = buf + *index; *type = get8(s); @@ -64,7 +55,9 @@ int ei_get_type_internal(const char *buf, const int *index, case ERL_LARGE_TUPLE_EXT: case ERL_LIST_EXT: + case ERL_MAP_EXT: case ERL_BINARY_EXT: + case ERL_BIT_BINARY_EXT: *len = get32be(s); break; diff --git a/lib/erl_interface/src/misc/show_msg.c b/lib/erl_interface/src/misc/show_msg.c index 5868cccba6..2d49eb6449 100644 --- a/lib/erl_interface/src/misc/show_msg.c +++ b/lib/erl_interface/src/misc/show_msg.c @@ -24,6 +24,13 @@ #include <stdlib.h> #include <stdarg.h> #include <string.h> +#ifdef HAVE_STDINT_H +# include <stdint.h> +#endif + +#ifndef SIZE_MAX +# define SIZE_MAX (~((size_t)0)) +#endif #include <sys/types.h> @@ -342,7 +349,7 @@ static void show_term(const char *termbuf, int *index, FILE *stream) int i, len; char *s; - ei_get_type_internal(termbuf,index,&type,&len); + ei_get_type(termbuf,index,&type,&len); switch (type) { case ERL_VERSION_MAGIC: @@ -455,6 +462,12 @@ static void show_term(const char *termbuf, int *index, FILE *stream) fprintf(stream,"#Bin<%ld>",num); break; + case ERL_BIT_BINARY_EXT: { + size_t bits; + ei_decode_bitstring(termbuf, index, NULL, SIZE_MAX, &bits); + fprintf(stream, "#Bits<%lu>", (unsigned long)bits); + break; + } case ERL_LARGE_BIG_EXT: /* doesn't actually decode - just skip over it */ /* FIXME if GMP, what to do here?? */ diff --git a/lib/erl_interface/src/prog/ei_fake_prog.c b/lib/erl_interface/src/prog/ei_fake_prog.c index 158464b385..6f58c9833d 100644 --- a/lib/erl_interface/src/prog/ei_fake_prog.c +++ b/lib/erl_interface/src/prog/ei_fake_prog.c @@ -186,7 +186,6 @@ int main(void) ei_x_encode_empty_list(&eix); ei_get_type(charp, intp, intp, intp); - ei_get_type_internal(charp, intp, intp, intp); ei_decode_version(charp, intp, intp); ei_decode_long(charp, intp, longp); diff --git a/lib/erl_interface/src/registry/reg_dump.c b/lib/erl_interface/src/registry/reg_dump.c index 43c9824433..da0413e6e6 100644 --- a/lib/erl_interface/src/registry/reg_dump.c +++ b/lib/erl_interface/src/registry/reg_dump.c @@ -90,7 +90,7 @@ static int mn_start_dump(int fd, const erlang_pid *self, || (arity != 2) || ei_decode_atom(buf,&index,tmpbuf) || strcmp(tmpbuf,"rex") - || ei_get_type_internal(buf,&index,&type,&arity) + || ei_get_type(buf,&index,&type,&arity) || (type != ERL_PID_EXT)) return -1; /* bad response from other side */ diff --git a/lib/erl_interface/test/all_SUITE_data/ei_runner.h b/lib/erl_interface/test/all_SUITE_data/ei_runner.h index 2608661303..7c874ac82e 100644 --- a/lib/erl_interface/test/all_SUITE_data/ei_runner.h +++ b/lib/erl_interface/test/all_SUITE_data/ei_runner.h @@ -53,6 +53,7 @@ void free_packet(char*); #define fail(reason) do_fail(__FILE__, __LINE__, reason) #define fail1(reason, a1) do_fail(__FILE__, __LINE__, reason, a1) +#define fail2(reason, a1, a2) do_fail(__FILE__, __LINE__, reason, a1, a2) #define report(ok) do_report(__FILE__, __LINE__, ok) void do_report(char* file, int line, int ok); diff --git a/lib/erl_interface/test/ei_accept_SUITE.erl b/lib/erl_interface/test/ei_accept_SUITE.erl index 9c9c3f86b6..f40c67375b 100644 --- a/lib/erl_interface/test/ei_accept_SUITE.erl +++ b/lib/erl_interface/test/ei_accept_SUITE.erl @@ -43,8 +43,12 @@ init_per_testcase(Case, Config) -> runner:init_per_testcase(?MODULE, Case, Config). ei_accept(Config) when is_list(Config) -> + ei_accept_do(Config, 0), % default + ei_accept_do(Config, 21). % ei_set_compat_rel + +ei_accept_do(Config, CompatRel) -> P = runner:start(Config, ?interpret), - 0 = ei_connect_init(P, 42, erlang:get_cookie(), 0), + 0 = ei_connect_init(P, 42, erlang:get_cookie(), 0, CompatRel), Myname = hd(tl(string:tokens(atom_to_list(node()), "@"))), io:format("Myname ~p ~n", [Myname]), @@ -52,15 +56,18 @@ ei_accept(Config) when is_list(Config) -> io:format("EINode ~p ~n", [EINode]), %% We take this opportunity to also test export-funs and bit-strings - %% with (ugly) tuple fallbacks. + %% with (ugly) tuple fallbacks in OTP 21 and older. %% Test both toward pending connection and established connection. RealTerms = [<<1:1>>, fun lists:map/2], - Fallbacks = [{<<128>>,1}, {lists,map}], + EncTerms = case CompatRel of + 0 -> RealTerms; + 21 -> [{<<128>>,1}, {lists,map}] + end, Self = self(), Funny = fun() -> hello end, TermToSend = {call, Self, "Test", Funny, RealTerms}, - TermToGet = {call, Self, "Test", Funny, Fallbacks}, + TermToGet = {call, Self, "Test", Funny, EncTerms}, Port = 6543, {ok, ListenFd} = ei_publish(P, Port), {any, EINode} ! TermToSend, @@ -94,7 +101,7 @@ ei_threaded_accept(Config) when is_list(Config) -> %% Test erlang:monitor toward erl_interface "processes" monitor_ei_process(Config) when is_list(Config) -> P = runner:start(Config, ?interpret), - 0 = ei_connect_init(P, 42, erlang:get_cookie(), 0), + 0 = ei_connect_init(P, 42, erlang:get_cookie(), 0, 0), Myname = hd(tl(string:tokens(atom_to_list(node()), "@"))), io:format("Myname ~p ~n", [Myname]), @@ -167,8 +174,8 @@ start_einode(Einode, N, Host) -> %%% Interface functions for ei (erl_interface) functions. -ei_connect_init(P, Num, Cookie, Creation) -> - send_command(P, ei_connect_init, [Num,Cookie,Creation]), +ei_connect_init(P, Num, Cookie, Creation, Compat) -> + send_command(P, ei_connect_init, [Num,Cookie,Creation,Compat]), case get_term(P) of {term,Int} when is_integer(Int) -> Int end. diff --git a/lib/erl_interface/test/ei_accept_SUITE_data/ei_accept_test.c b/lib/erl_interface/test/ei_accept_SUITE_data/ei_accept_test.c index c209f506b1..09b0b5440b 100644 --- a/lib/erl_interface/test/ei_accept_SUITE_data/ei_accept_test.c +++ b/lib/erl_interface/test/ei_accept_SUITE_data/ei_accept_test.c @@ -58,7 +58,7 @@ static struct { int num_args; /* Number of arguments. */ void (*func)(char* buf, int len); } commands[] = { - "ei_connect_init", 3, cmd_ei_connect_init, + "ei_connect_init", 4, cmd_ei_connect_init, "ei_publish", 1, cmd_ei_publish, "ei_accept", 1, cmd_ei_accept, "ei_receive", 1, cmd_ei_receive, @@ -106,21 +106,25 @@ TESTCASE(interpret) static void cmd_ei_connect_init(char* buf, int len) { int index = 0, r = 0; - int type, size; - long l; - char b[100]; + long num, creation; + unsigned long compat; + char node_name[100]; char cookie[MAXATOMLEN], * cp = cookie; ei_x_buff res; - if (ei_decode_long(buf, &index, &l) < 0) + if (ei_decode_long(buf, &index, &num) < 0) fail("expected int"); - sprintf(b, "c%d", l); - /* FIXME don't use internal and maybe use skip?! */ - ei_get_type_internal(buf, &index, &type, &size); + sprintf(node_name, "c%d", num); if (ei_decode_atom(buf, &index, cookie) < 0) fail("expected atom (cookie)"); if (cookie[0] == '\0') cp = NULL; - r = ei_connect_init(&ec, b, cp, 0); + if (ei_decode_long(buf, &index, &creation) < 0) + fail("expected int"); + if (ei_decode_long(buf, &index, &compat) < 0) + fail("expected uint"); + if (compat) + ei_set_compat_rel(compat); + r = ei_connect_init(&ec, node_name, cp, creation); ei_x_new_with_version(&res); ei_x_encode_long(&res, r); send_bin_term(&res); diff --git a/lib/erl_interface/test/ei_connect_SUITE.erl b/lib/erl_interface/test/ei_connect_SUITE.erl index 75b6bf18da..6184ce801b 100644 --- a/lib/erl_interface/test/ei_connect_SUITE.erl +++ b/lib/erl_interface/test/ei_connect_SUITE.erl @@ -79,9 +79,10 @@ ei_send_funs(Config) when is_list(Config) -> {ok,Fd} = ei_connect(P, node()), Fun1 = fun ei_send/1, - Fun2 = fun(X) -> P, X, Fd, Fun1 end, + Fun2 = fun(X) -> {P, X, Fd, Fun1} end, + Bits = <<1,2,3:5>>, - AMsg={Fun1,Fun2}, + AMsg={Fun1,Fun2,Bits}, %%AMsg={wait_with_funs, new_dist_format}, ok = ei_send_funs(P, Fd, self(), AMsg), EIMsg = receive M -> M end, diff --git a/lib/erl_interface/test/ei_connect_SUITE_data/ei_connect_test.c b/lib/erl_interface/test/ei_connect_SUITE_data/ei_connect_test.c index 58c0c7f8d8..7c9e79f837 100644 --- a/lib/erl_interface/test/ei_connect_SUITE_data/ei_connect_test.c +++ b/lib/erl_interface/test/ei_connect_SUITE_data/ei_connect_test.c @@ -107,7 +107,6 @@ TESTCASE(interpret) static void cmd_ei_connect_init(char* buf, int len) { int index = 0, r = 0; - int type, size; long l; char b[100]; char cookie[MAXATOMLEN], * cp = cookie; @@ -115,8 +114,6 @@ static void cmd_ei_connect_init(char* buf, int len) if (ei_decode_long(buf, &index, &l) < 0) fail("expected int"); sprintf(b, "c%ld", l); - /* FIXME don't use internal and maybe use skip?! */ - ei_get_type_internal(buf, &index, &type, &size); if (ei_decode_atom(buf, &index, cookie) < 0) fail("expected atom (cookie)"); if (cookie[0] == '\0') @@ -212,6 +209,8 @@ static void cmd_ei_send_funs(char* buf, int len) erlang_pid pid; ei_x_buff x; erlang_fun fun1, fun2; + unsigned char bitstring[10]; + size_t bits; if (ei_decode_long(buf, &index, &fd) < 0) fail("expected long"); @@ -219,20 +218,24 @@ static void cmd_ei_send_funs(char* buf, int len) fail("expected pid (node)"); if (ei_decode_tuple_header(buf, &index, &n) < 0) fail("expected tuple"); - if (n != 2) + if (n != 3) fail("expected tuple"); if (ei_decode_fun(buf, &index, &fun1) < 0) fail("expected Fun1"); if (ei_decode_fun(buf, &index, &fun2) < 0) fail("expected Fun2"); + if (ei_decode_bitstring(buf, &index, bitstring, sizeof(bitstring), &bits) < 0) + fail("expected bitstring"); if (ei_x_new_with_version(&x) < 0) fail("ei_x_new_with_version"); - if (ei_x_encode_tuple_header(&x, 2) < 0) + if (ei_x_encode_tuple_header(&x, 3) < 0) fail("encode tuple header"); if (ei_x_encode_fun(&x, &fun1) < 0) fail("encode fun1"); if (ei_x_encode_fun(&x, &fun2) < 0) fail("encode fun2"); + if (ei_x_encode_bitstring(&x, bitstring, bits) < 0) + fail("encode bitstring"); free_fun(&fun1); free_fun(&fun2); send_errno_result(ei_send(fd, &pid, x.buff, x.index)); diff --git a/lib/erl_interface/test/ei_decode_SUITE.erl b/lib/erl_interface/test/ei_decode_SUITE.erl index 75560ea7c9..e005ec89c7 100644 --- a/lib/erl_interface/test/ei_decode_SUITE.erl +++ b/lib/erl_interface/test/ei_decode_SUITE.erl @@ -194,6 +194,9 @@ test_ei_decode_misc(Config) when is_list(Config) -> send_term_as_binary(P,<<>>), send_term_as_binary(P,<<"ÅÄÖåäö">>), + send_term_as_binary(P,<<1, 2, 3:5>>), + send_term_as_binary(P,<<1:1>>), + % send_term_as_binary(P,{}), % send_term_as_binary(P,[]), diff --git a/lib/erl_interface/test/ei_decode_SUITE_data/ei_decode_test.c b/lib/erl_interface/test/ei_decode_SUITE_data/ei_decode_test.c index e516f310b6..d39970a857 100644 --- a/lib/erl_interface/test/ei_decode_SUITE_data/ei_decode_test.c +++ b/lib/erl_interface/test/ei_decode_SUITE_data/ei_decode_test.c @@ -256,66 +256,129 @@ int ei_decode_my_string(const char *buf, int *index, char *to, //#define EI_DECODE_UTF8_STRING(FUNC,SIZE,VAL) -#define EI_DECODE_BIN(FUNC,SIZE,VAL,LEN) \ - { \ - char p[1024]; \ - char *buf; \ - long len; \ - int size1 = 0; \ - int size2 = 0; \ - int err; \ - message("ei_" #FUNC " should be " #VAL); \ - buf = read_packet(NULL); \ - err = ei_ ## FUNC(buf+1, &size1, NULL, &len); \ +static void decode_bin(int exp_size, const char* val, int exp_len) +{ + char p[1024]; + char *buf; + long len; + int size1 = 0; + int size2 = 0; + int err; + message("ei_decode_binary should be %s", val); + buf = read_packet(NULL); + err = ei_decode_binary(buf+1, &size1, NULL, &len); message("err = %d, size = %d, len = %d, expected size = %d, expected len = %d\n",\ - err,size1,len,SIZE,LEN); \ - if (err != 0) { \ - if (err != -1) { \ - fail("returned non zero but not -1 if NULL pointer"); \ - } else { \ - fail("returned non zero"); \ - } \ - return; \ - } \ -\ - if (len != LEN) { \ - fail("size is not correct"); \ - return; \ - } \ -\ - err = ei_ ## FUNC(buf+1, &size2, p, &len); \ + err,size1,len, exp_size, exp_len); + if (err != 0) { + if (err != -1) { + fail("returned non zero but not -1 if NULL pointer"); + } else { + fail("returned non zero"); + } + return; + } + + if (len != exp_len) { + fail("size is not correct"); + return; + } + + err = ei_decode_binary(buf+1, &size2, p, &len); message("err = %d, size = %d, len = %d, expected size = %d, expected len = %d\n",\ - err,size2,len,SIZE,LEN); \ - if (err != 0) { \ - if (err != -1) { \ - fail("returned non zero but not -1 if NULL pointer"); \ - } else { \ - fail("returned non zero"); \ - } \ - return; \ - } \ -\ - if (len != LEN) { \ - fail("size is not correct"); \ - return; \ - } \ -\ - if (strncmp(p,VAL,LEN) != 0) { \ - fail("value is not correct"); \ - return; \ - } \ -\ - if (size1 != size2) { \ - fail("size with and without pointer differs"); \ - return; \ - } \ -\ - if (size1 != SIZE) { \ - fail("size of encoded data is incorrect"); \ - return; \ - } \ - free_packet(buf); \ - } \ + err,size2,len, exp_size, exp_len); + if (err != 0) { + if (err != -1) { + fail("returned non zero but not -1 if NULL pointer"); + } else { + fail("returned non zero"); + } + return; + } + + if (len != exp_len) { + fail("size is not correct"); + return; + } + + if (strncmp(p,val,exp_len) != 0) { + fail("value is not correct"); + return; + } + + if (size1 != size2) { + fail("size with and without pointer differs"); + return; + } + + if (size1 != exp_size) { + fail("size of encoded data is incorrect"); + return; + } + free_packet(buf); +} + +static void decode_bits(int exp_size, const char* val, size_t exp_bits) +{ + char p[1024]; + char *buf; + size_t bits; + int size1 = 0; + int size2 = 0; + int err; + message("ei_decode_bitstring should be %d bits", (int)exp_bits); + buf = read_packet(NULL); + err = ei_decode_bitstring(buf+1, &size1, NULL, sizeof(p), &bits); + message("err = %d, size = %d, len = %d, expected size = %d, expected bits = %d\n",\ + err,size1, (int)bits, exp_size, (int)exp_bits); + + if (err != 0) { + if (err != -1) { + fail("returned non zero but not -1 if NULL pointer"); + } else { + fail("returned non zero"); + } + return; + } + + if (bits != exp_bits) { + fail("number of bits is not correct"); + return; + } + + err = ei_decode_bitstring(buf+1, &size2, p, sizeof(p), &bits); + message("err = %d, size = %d, len = %d, expected size = %d, expected len = %d\n",\ + err,size2, (int)bits, exp_size, (int)exp_bits); + if (err != 0) { + if (err != -1) { + fail("returned non zero but not -1 if NULL pointer"); + } else { + fail("returned non zero"); + } + return; + } + + if (bits != exp_bits) { + fail("bits is not correct"); + return; + } + + if (memcmp(p, val, (exp_bits+7)/8) != 0) { + fail("value is not correct"); + return; + } + + if (size1 != size2) { + fail("size with and without pointer differs"); + return; + } + + if (size1 != exp_size) { + fail2("size of encoded data is incorrect %d != %d", size1, exp_size); + return; + } + free_packet(buf); +} + /* ******************************************************************** */ @@ -644,9 +707,17 @@ TESTCASE(test_ei_decode_misc) EI_DECODE_STRING(decode_my_string, 1, ""); EI_DECODE_STRING(decode_my_string, 9, "������"); - EI_DECODE_BIN(decode_binary, 8, "foo", 3); - EI_DECODE_BIN(decode_binary, 5, "", 0); - EI_DECODE_BIN(decode_binary, 11, "������", 6); + decode_bin(8, "foo", 3); + decode_bin(5, "", 0); + decode_bin(11, "������", 6); + +#define LAST_BYTE(V, BITS) ((V) << (8-(BITS))) + { + unsigned char bits1[] = {1, 2, LAST_BYTE(3,5) }; + unsigned char bits2[] = {LAST_BYTE(1,1) }; + decode_bits(9, bits1, 21); + decode_bits(7, bits2, 1); + } /* FIXME check \0 in strings and atoms? */ /* diff --git a/lib/erl_interface/test/ei_decode_encode_SUITE.erl b/lib/erl_interface/test/ei_decode_encode_SUITE.erl index 0f23cdfbb9..d8b0bce3ae 100644 --- a/lib/erl_interface/test/ei_decode_encode_SUITE.erl +++ b/lib/erl_interface/test/ei_decode_encode_SUITE.erl @@ -120,6 +120,8 @@ test_ei_decode_encode(Config) when is_list(Config) -> send_rec(P, #{key => value}), send_rec(P, maps:put(Port, Ref, #{key => value, key2 => Pid})), + [send_rec(P, <<16#dec0deb175:B/little>>) || B <- lists:seq(0,48)], + runner:recv_eot(P), ok. diff --git a/lib/erl_interface/test/ei_decode_encode_SUITE_data/ei_decode_encode_test.c b/lib/erl_interface/test/ei_decode_encode_SUITE_data/ei_decode_encode_test.c index 55d9ed1b1a..f9c05b2739 100644 --- a/lib/erl_interface/test/ei_decode_encode_SUITE_data/ei_decode_encode_test.c +++ b/lib/erl_interface/test/ei_decode_encode_SUITE_data/ei_decode_encode_test.c @@ -40,6 +40,12 @@ typedef struct erlang_char_encoding enc; }my_atom; +typedef struct +{ + char bytes[MAXATOMLEN_UTF8]; + size_t nbits; +}my_bitstring; + struct my_obj { union { erlang_fun fun; @@ -49,6 +55,7 @@ struct my_obj { erlang_trace trace; erlang_big big; my_atom atom; + my_bitstring bits; int arity; }u; @@ -119,6 +126,26 @@ struct Type my_atom_type = { (encodeFT*)ei_encode_my_atom, (x_encodeFT*)ei_x_encode_my_atom }; +int ei_decode_my_bits(const char *buf, int *index, my_bitstring* a) +{ + return ei_decode_bitstring(buf, index, (a ? a->bytes : NULL), + sizeof(a->bytes), + (a ? &a->nbits : NULL)); +} +int ei_encode_my_bits(char *buf, int *index, my_bitstring* a) +{ + return ei_encode_bitstring(buf, index, a->bytes, a->nbits); +} +int ei_x_encode_my_bits(ei_x_buff* x, my_bitstring* a) +{ + return ei_x_encode_bitstring(x, a->bytes, a->nbits); +} + +struct Type my_bitstring_type = { + "bits", "my_bitstring", (decodeFT*)ei_decode_my_bits, + (encodeFT*)ei_encode_my_bits, (x_encodeFT*)ei_x_encode_my_bits +}; + int my_decode_tuple_header(const char *buf, int *index, struct my_obj* obj) { @@ -537,6 +564,10 @@ TESTCASE(test_ei_decode_encode) decode_encode(map, 7); } + for (i=0; i <= 48; i++) { + decode_encode_one(&my_bitstring_type); + } + report(1); } diff --git a/lib/jinterface/java_src/com/ericsson/otp/erlang/AbstractNode.java b/lib/jinterface/java_src/com/ericsson/otp/erlang/AbstractNode.java index 222330654a..c3f71a84f0 100644 --- a/lib/jinterface/java_src/com/ericsson/otp/erlang/AbstractNode.java +++ b/lib/jinterface/java_src/com/ericsson/otp/erlang/AbstractNode.java @@ -89,7 +89,7 @@ public class AbstractNode implements OtpTransportFactory { static final int dFlagHiddenAtomCache = 0x40; // NOT SUPPORTED static final int dflagNewFunTags = 0x80; static final int dFlagExtendedPidsPorts = 0x100; - static final int dFlagExportPtrTag = 0x200; // NOT SUPPORTED + static final int dFlagExportPtrTag = 0x200; static final int dFlagBitBinaries = 0x400; static final int dFlagNewFloats = 0x800; static final int dFlagUnicodeIo = 0x1000; @@ -105,6 +105,7 @@ public class AbstractNode implements OtpTransportFactory { int flags = dFlagExtendedReferences | dFlagExtendedPidsPorts | dFlagBitBinaries | dFlagNewFloats | dFlagFunTags | dflagNewFunTags | dFlagUtf8Atoms | dFlagMapTag + | dFlagExportPtrTag | dFlagBigCreation; /* initialize hostname and default cookie */ diff --git a/lib/jinterface/test/nc_SUITE.erl b/lib/jinterface/test/nc_SUITE.erl index 4f225a396e..7833d070b7 100644 --- a/lib/jinterface/test/nc_SUITE.erl +++ b/lib/jinterface/test/nc_SUITE.erl @@ -142,7 +142,8 @@ fun_roundtrip(Config) when is_list(Config)-> do_echo([fun(A, B) -> A + B end, fun(A) -> lists:reverse(A) end, fun() -> ok end, - fun fun_roundtrip/1], + fun fun_roundtrip/1, + fun ?MODULE:fun_roundtrip/1], Config). port_roundtrip(doc) -> []; diff --git a/lib/snmp/src/misc/snmp_misc.erl b/lib/snmp/src/misc/snmp_misc.erl index 0cc04d4056..39254503ac 100644 --- a/lib/snmp/src/misc/snmp_misc.erl +++ b/lib/snmp/src/misc/snmp_misc.erl @@ -151,41 +151,41 @@ formated_long_timestamp() -> %% the date in the formatted timestamp. %% --------------------------------------------------------------------------- --spec format_timestamp(Now :: os:timestamp()) -> +-spec format_timestamp(Now :: erlang:timestamp()) -> string(). format_timestamp(Now) -> format_long_timestamp(Now). --spec format_short_timestamp(Now :: os:timestamp()) -> +-spec format_short_timestamp(Now :: erlang:timestamp()) -> string(). format_short_timestamp(Now) -> N2T = fun(N) -> calendar:now_to_local_time(N) end, format_timestamp(short, Now, N2T). --spec format_long_timestamp(Now :: os:timestamp()) -> +-spec format_long_timestamp(Now :: erlang:timestamp()) -> string(). format_long_timestamp(Now) -> N2T = fun(N) -> calendar:now_to_local_time(N) end, format_timestamp(long, Now, N2T). --spec format_timestamp(Now :: os:timestamp(), +-spec format_timestamp(Now :: erlang:timestamp(), N2T :: function()) -> string(). format_timestamp(Now, N2T) when is_tuple(Now) andalso is_function(N2T) -> format_long_timestamp(Now, N2T). --spec format_short_timestamp(Now :: os:timestamp(), +-spec format_short_timestamp(Now :: erlang:timestamp(), N2T :: function()) -> string(). format_short_timestamp(Now, N2T) when is_tuple(Now) andalso is_function(N2T) -> format_timestamp(short, Now, N2T). --spec format_long_timestamp(Now :: os:timestamp(), +-spec format_long_timestamp(Now :: erlang:timestamp(), N2T :: function()) -> string(). @@ -195,14 +195,8 @@ format_long_timestamp(Now, N2T) when is_tuple(Now) andalso is_function(N2T) -> format_timestamp(Format, {_N1, _N2, N3} = Now, N2T) -> {Date, Time} = N2T(Now), do_format_timestamp(Format, Date, Time, N3). - %% case Format of - %% short -> - %% do_format_short_timestamp(Time, N3); - %% long -> - %% do_format_long_timestamp(Date, Time, N3) - %% end. - -do_format_timestamp(short, Date, Time, N3) -> + +do_format_timestamp(short, _Date, Time, N3) -> do_format_short_timestamp(Time, N3); do_format_timestamp(long, Date, Time, N3) -> do_format_long_timestamp(Date, Time, N3). diff --git a/lib/ssh/src/ssh.hrl b/lib/ssh/src/ssh.hrl index 923e9309f4..04453e6ef0 100644 --- a/lib/ssh/src/ssh.hrl +++ b/lib/ssh/src/ssh.hrl @@ -396,11 +396,13 @@ recv_mac_size = 0, encrypt = none, %% encrypt algorithm + encrypt_cipher, %% cipher. could be different from the algorithm encrypt_keys, %% encrypt keys encrypt_block_size = 8, encrypt_ctx, decrypt = none, %% decrypt algorithm + decrypt_cipher, %% cipher. could be different from the algorithm decrypt_keys, %% decrypt keys decrypt_block_size = 8, decrypt_ctx, %% Decryption context diff --git a/lib/ssh/src/ssh_sftpd.erl b/lib/ssh/src/ssh_sftpd.erl index aa9ba0f9bb..5ec12e2d04 100644 --- a/lib/ssh/src/ssh_sftpd.erl +++ b/lib/ssh/src/ssh_sftpd.erl @@ -508,7 +508,7 @@ close_our_file({_,Fd}, FileMod, FS0) -> FS1. %%% stat: do the stat -stat(Vsn, ReqId, Data, State, F) -> +stat(_Vsn, ReqId, Data, State, F) -> <<?UINT32(BLen), BPath:BLen/binary, _/binary>> = Data, stat(ReqId, unicode:characters_to_list(BPath), State, F). diff --git a/lib/ssh/src/ssh_transport.erl b/lib/ssh/src/ssh_transport.erl index 2299346a30..eaab13433a 100644 --- a/lib/ssh/src/ssh_transport.erl +++ b/lib/ssh/src/ssh_transport.erl @@ -1328,13 +1328,15 @@ verify(PlainText, HashAlg, Sig, Key, _) -> %%% Start of a more parameterized crypto handling. cipher('AEAD_AES_128_GCM') -> - #cipher{key_bytes = 16, + #cipher{impl = aes_128_gcm, + key_bytes = 16, iv_bytes = 12, block_bytes = 16, pkt_type = aead}; cipher('AEAD_AES_256_GCM') -> - #cipher{key_bytes = 32, + #cipher{impl = aes_256_gcm, + key_bytes = 32, iv_bytes = 12, block_bytes = 16, pkt_type = aead}; @@ -1346,7 +1348,7 @@ cipher('3des-cbc') -> block_bytes = 8}; cipher('aes128-cbc') -> - #cipher{impl = aes_cbc, + #cipher{impl = aes_128_cbc, key_bytes = 16, iv_bytes = 16, block_bytes = 16}; @@ -1370,7 +1372,8 @@ cipher('aes256-ctr') -> block_bytes = 16}; cipher('[email protected]') -> % FIXME: Verify!! - #cipher{key_bytes = 32, + #cipher{impl = chacha20_poly1305, + key_bytes = 32, iv_bytes = 12, block_bytes = 8, pkt_type = aead}; @@ -1407,12 +1410,14 @@ encrypt_init(#ssh{encrypt = '[email protected]', role = Role} = Ssh) encrypt_init(#ssh{encrypt = SshCipher, role = Role} = Ssh) when SshCipher == 'AEAD_AES_128_GCM'; SshCipher == 'AEAD_AES_256_GCM' -> {IvMagic, KeyMagic} = encrypt_magic(Role), - #cipher{key_bytes = KeyBytes, + #cipher{impl = CryptoCipher, + key_bytes = KeyBytes, iv_bytes = IvBytes, block_bytes = BlockBytes} = cipher(SshCipher), IV = hash(Ssh, IvMagic, 8*IvBytes), K = hash(Ssh, KeyMagic, 8*KeyBytes), - {ok, Ssh#ssh{encrypt_keys = K, + {ok, Ssh#ssh{encrypt_cipher = CryptoCipher, + encrypt_keys = K, encrypt_block_size = BlockBytes, encrypt_ctx = IV}}; @@ -1425,11 +1430,12 @@ encrypt_init(#ssh{encrypt = SshCipher, role = Role} = Ssh) -> IV = hash(Ssh, IvMagic, 8*IvBytes), K = hash(Ssh, KeyMagic, 8*KeyBytes), Ctx0 = crypto:crypto_init(CryptoCipher, K, IV, true), - {ok, Ssh#ssh{encrypt_block_size = BlockBytes, + {ok, Ssh#ssh{encrypt_cipher = CryptoCipher, + encrypt_block_size = BlockBytes, encrypt_ctx = Ctx0}}. encrypt_final(Ssh) -> - {ok, Ssh#ssh{encrypt = none, + {ok, Ssh#ssh{encrypt = none, encrypt_keys = undefined, encrypt_block_size = 8, encrypt_ctx = undefined @@ -1457,18 +1463,19 @@ encrypt(#ssh{encrypt = '[email protected]', {Ssh, {EncBytes,Ctag}}; encrypt(#ssh{encrypt = SshCipher, + encrypt_cipher = CryptoCipher, encrypt_keys = K, encrypt_ctx = IV0} = Ssh, <<LenData:4/binary, PayloadData/binary>>) when SshCipher == 'AEAD_AES_128_GCM' ; SshCipher == 'AEAD_AES_256_GCM' -> - {Ctext,Ctag} = crypto:block_encrypt(aes_gcm, K, IV0, {LenData,PayloadData}), + {Ctext,Ctag} = crypto:crypto_one_time_aead(CryptoCipher, K, IV0, PayloadData, LenData, true), IV = next_gcm_iv(IV0), {Ssh#ssh{encrypt_ctx = IV}, {<<LenData/binary,Ctext/binary>>,Ctag}}; encrypt(#ssh{encrypt_ctx = Ctx0} = Ssh, Data) -> Enc = crypto:crypto_update(Ctx0, Data), {Ssh, Enc}. - + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% Decryption %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -1485,12 +1492,14 @@ decrypt_init(#ssh{decrypt = '[email protected]', role = Role} = Ssh) decrypt_init(#ssh{decrypt = SshCipher, role = Role} = Ssh) when SshCipher == 'AEAD_AES_128_GCM'; SshCipher == 'AEAD_AES_256_GCM' -> {IvMagic, KeyMagic} = decrypt_magic(Role), - #cipher{key_bytes = KeyBytes, + #cipher{impl = CryptoCipher, + key_bytes = KeyBytes, iv_bytes = IvBytes, block_bytes = BlockBytes} = cipher(SshCipher), IV = hash(Ssh, IvMagic, 8*IvBytes), K = hash(Ssh, KeyMagic, 8*KeyBytes), - {ok, Ssh#ssh{decrypt_keys = K, + {ok, Ssh#ssh{decrypt_cipher = CryptoCipher, + decrypt_keys = K, decrypt_block_size = BlockBytes, decrypt_ctx = IV}}; @@ -1503,9 +1512,11 @@ decrypt_init(#ssh{decrypt = SshCipher, role = Role} = Ssh) -> IV = hash(Ssh, IvMagic, 8*IvBytes), K = hash(Ssh, KeyMagic, 8*KeyBytes), Ctx0 = crypto:crypto_init(CryptoCipher, K, IV, false), - {ok, Ssh#ssh{decrypt_block_size = BlockBytes, + {ok, Ssh#ssh{decrypt_cipher = CryptoCipher, + decrypt_block_size = BlockBytes, decrypt_ctx = Ctx0}}. + decrypt_final(Ssh) -> {ok, Ssh#ssh {decrypt = none, decrypt_keys = undefined, @@ -1517,35 +1528,37 @@ decrypt(Ssh, <<>>) -> {Ssh, <<>>}; decrypt(#ssh{decrypt = '[email protected]', - decrypt_keys = {K1,_K2}, - recv_sequence = Seq} = Ssh, {length,EncryptedLen}) -> - PacketLenBin = crypto:crypto_one_time(chacha20, K1, <<0:8/unit:8, Seq:8/unit:8>>, EncryptedLen, false), - {Ssh, PacketLenBin}; - -decrypt(#ssh{decrypt = '[email protected]', - decrypt_keys = {_K1,K2}, - recv_sequence = Seq} = Ssh, {AAD,Ctext,Ctag}) -> - %% The length is already decoded and used to divide the input - %% Check the mac (important that it is timing-safe): - PolyKey = crypto:crypto_one_time(chacha20, K2, <<0:8/unit:8,Seq:8/unit:8>>, <<0:32/unit:8>>, false), - case equal_const_time(Ctag, crypto:poly1305(PolyKey, <<AAD/binary,Ctext/binary>>)) of - true -> - %% MAC is ok, decode - IV2 = <<1:8/little-unit:8, Seq:8/unit:8>>, - PlainText = crypto:crypto_one_time(chacha20, K2, IV2, Ctext, false), - {Ssh, PlainText}; - false -> - {Ssh,error} + decrypt_keys = {K1,K2}, + recv_sequence = Seq} = Ssh, Data) -> + case Data of + {length,EncryptedLen} -> + %% The length is decrypted separately in a first step + PacketLenBin = crypto:crypto_one_time(chacha20, K1, <<0:8/unit:8, Seq:8/unit:8>>, EncryptedLen, false), + {Ssh, PacketLenBin}; + {AAD,Ctext,Ctag} -> + %% The length is already decrypted and used to divide the input + %% Check the mac (important that it is timing-safe): + PolyKey = crypto:crypto_one_time(chacha20, K2, <<0:8/unit:8,Seq:8/unit:8>>, <<0:32/unit:8>>, false), + case equal_const_time(Ctag, crypto:poly1305(PolyKey, <<AAD/binary,Ctext/binary>>)) of + true -> + %% MAC is ok, decode + IV2 = <<1:8/little-unit:8, Seq:8/unit:8>>, + PlainText = crypto:crypto_one_time(chacha20, K2, IV2, Ctext, false), + {Ssh, PlainText}; + false -> + {Ssh,error} + end end; decrypt(#ssh{decrypt = none} = Ssh, Data) -> {Ssh, Data}; decrypt(#ssh{decrypt = SshCipher, + decrypt_cipher = CryptoCipher, decrypt_keys = K, - decrypt_ctx = IV0} = Ssh, Data = {_AAD,_Ctext,_Ctag}) when SshCipher == 'AEAD_AES_128_GCM' ; - SshCipher == 'AEAD_AES_256_GCM' -> - Dec = crypto:block_decrypt(aes_gcm, K, IV0, Data), % Dec = PlainText | error + decrypt_ctx = IV0} = Ssh, {AAD,Ctext,Ctag}) when SshCipher == 'AEAD_AES_128_GCM' ; + SshCipher == 'AEAD_AES_256_GCM' -> + Dec = crypto:crypto_one_time_aead(CryptoCipher, K, IV0, Ctext, AAD, Ctag, false), IV = next_gcm_iv(IV0), {Ssh#ssh{decrypt_ctx = IV}, Dec}; diff --git a/lib/ssh/test/ssh_basic_SUITE.erl b/lib/ssh/test/ssh_basic_SUITE.erl index 5de6d52092..9b987dea5a 100644 --- a/lib/ssh/test/ssh_basic_SUITE.erl +++ b/lib/ssh/test/ssh_basic_SUITE.erl @@ -1399,7 +1399,7 @@ rekey_chk(Config, RLdaemon, RLclient) -> Kex1 = ssh_test_lib:get_kex_init(ConnectionRef), %% Make both sides send something: - {ok, SftpPid} = ssh_sftp:start_channel(ConnectionRef), + {ok, _SftpPid} = ssh_sftp:start_channel(ConnectionRef), %% Check rekeying timer:sleep(?REKEY_DATA_TMO), diff --git a/lib/ssh/test/ssh_bench_SUITE.erl b/lib/ssh/test/ssh_bench_SUITE.erl index 2ac4e5636a..880c519a5e 100644 --- a/lib/ssh/test/ssh_bench_SUITE.erl +++ b/lib/ssh/test/ssh_bench_SUITE.erl @@ -178,7 +178,7 @@ gen_data(DataSz) -> connect_measure(Port, Cipher, Mac, Data, Options) -> - AES_GCM = {cipher, + _AES_GCM = {cipher, []}, %% ['[email protected]', %% '[email protected]']}, @@ -187,22 +187,22 @@ connect_measure(Port, Cipher, Mac, Data, Options) -> {none,none} -> [{modify_algorithms,[{prepend, [{cipher,[Cipher]}, {mac,[Mac]}]} -%%% ,{rm,[AES_GCM]} +%%% ,{rm,[_AES_GCM]} ]}]; {none,_} -> [{modify_algorithms,[{prepend, [{cipher,[Cipher]}]} -%%% ,{rm,[AES_GCM]} +%%% ,{rm,[_AES_GCM]} ]}, {preferred_algorithms, [{mac,[Mac]}]}]; {_,none} -> [{modify_algorithms,[{prepend, [{mac,[Mac]}]} -%%% ,{rm,[AES_GCM]} +%%% ,{rm,[_AES_GCM]} ]}, {preferred_algorithms, [{cipher,[Cipher]}]}]; _ -> [{preferred_algorithms, [{cipher,[Cipher]}, {mac,[Mac]}]} -%%% ,{modify_algorithms, [{rm,[AES_GCM]}]} +%%% ,{modify_algorithms, [{rm,[_AES_GCM]}]} ] end, Times = diff --git a/lib/ssh/test/ssh_chan_behaviours_SUITE.erl b/lib/ssh/test/ssh_chan_behaviours_SUITE.erl index 16ed152bcd..103d7253fd 100644 --- a/lib/ssh/test/ssh_chan_behaviours_SUITE.erl +++ b/lib/ssh/test/ssh_chan_behaviours_SUITE.erl @@ -128,8 +128,8 @@ subsystem_client(Config) -> C = proplists:get_value(connref, Config), {ok,ChRef} = ssh_chan_behaviours_client:start_link(C), - IDclt = ?EXPECT({{C,Ch1clt}, {ssh_channel_up,Ch1clt,C}}, {C,Ch1clt}), - IDsrv = ?EXPECT({{_Csrv,Ch1srv}, {ssh_channel_up,Ch1srv,_Csrv}}, {_Csrv,Ch1srv}), + IDclt = ?EXPECT({{C,_Ch1clt}, {ssh_channel_up,_Ch1clt,C}}, {C,_Ch1clt}), + IDsrv = ?EXPECT({{_Csrv,_Ch1srv}, {ssh_channel_up,_Ch1srv,_Csrv}}, {_Csrv,_Ch1srv}), ok = ssh_chan_behaviours_client:stop(ChRef), ?EXPECT({IDclt, {terminate,normal}}, []), % From the proper channel handler diff --git a/lib/ssh/test/ssh_chan_behaviours_client.erl b/lib/ssh/test/ssh_chan_behaviours_client.erl index 15f17733d6..8dd18973ad 100644 --- a/lib/ssh/test/ssh_chan_behaviours_client.erl +++ b/lib/ssh/test/ssh_chan_behaviours_client.erl @@ -94,7 +94,7 @@ handle_ssh_msg({ssh_cm, C, {eof, Ch}}=M, #state{ch=Ch,cm=C} = State) -> ?DBG(State, "eof",[]), {ok, State}; -handle_ssh_msg({ssh_cm, C, {signal, _Ch, _SigNameStr}=Sig} = M, #state{ch=Ch,cm=C} = State) -> +handle_ssh_msg({ssh_cm, C, {signal, Ch, _SigNameStr}=Sig} = M, #state{ch=Ch,cm=C} = State) -> %% Ignore signals according to RFC 4254 section 6.9. tell_parent(M, State), ?DBG(State, "~p",[Sig]), diff --git a/lib/ssh/test/ssh_chan_behaviours_server.erl b/lib/ssh/test/ssh_chan_behaviours_server.erl index 1408675a6e..1d504b1bc6 100644 --- a/lib/ssh/test/ssh_chan_behaviours_server.erl +++ b/lib/ssh/test/ssh_chan_behaviours_server.erl @@ -65,7 +65,7 @@ handle_ssh_msg({ssh_cm, C, {eof, Ch}}=M, #state{ch=Ch,cm=C} = State) -> ?DBG(State, "eof",[]), {ok, State}; -handle_ssh_msg({ssh_cm, C, {signal, _Ch, _SigNameStr}=Sig} = M, #state{ch=Ch,cm=C} = State) -> +handle_ssh_msg({ssh_cm, C, {signal, Ch, _SigNameStr}=Sig} = M, #state{ch=Ch,cm=C} = State) -> %% Ignore signals according to RFC 4254 section 6.9. tell_parent(M, State), ?DBG(State, "~p",[Sig]), diff --git a/lib/ssh/test/ssh_compat_SUITE.erl b/lib/ssh/test/ssh_compat_SUITE.erl index 8e82527c6e..06ed9082cf 100644 --- a/lib/ssh/test/ssh_compat_SUITE.erl +++ b/lib/ssh/test/ssh_compat_SUITE.erl @@ -150,8 +150,7 @@ init_per_group(G, Config0) -> stop_docker(ID), {fail, "Can't contact docker sshd"} catch - Class:Exc -> - ST = erlang:get_stacktrace(), + Class:Exc:ST -> ct:log("common_algs: ~p:~p~n~p",[Class,Exc,ST]), stop_docker(ID), {fail, "Failed during setup"} @@ -160,8 +159,7 @@ init_per_group(G, Config0) -> cant_start_docker -> {skip, "Can't start docker"}; - C:E -> - ST = erlang:get_stacktrace(), + C:E:ST -> ct:log("No ~p~n~p:~p~n~p",[G,C,E,ST]), {skip, "Can't start docker"} end; @@ -1026,8 +1024,7 @@ receive_hello(S) -> Result -> Result catch - Class:Error -> - ST = erlang:get_stacktrace(), + Class:Error:ST -> {error, {Class,Error,ST}} end. @@ -1104,8 +1101,7 @@ sftp_tests_erl_server(Config, ServerIP, ServerPort, ServerRootDir, UserDir) -> call_sftp_in_docker(Config, ServerIP, ServerPort, Cmnds, UserDir), check_local_directory(ServerRootDir) catch - Class:Error -> - ST = erlang:get_stacktrace(), + Class:Error:ST -> {error, {Class,Error,ST}} end. @@ -1133,7 +1129,7 @@ check_local_directory(ServerRootDir) -> check_local_directory(ServerRootDir, SleepTime, N) -> case do_check_local_directory(ServerRootDir) of - {error,Error} when N>0 -> + {error,_Error} when N>0 -> %% Could be that the erlang side is faster and the docker's operations %% are not yet finalized. %% Sleep for a while and retry a few times: @@ -1347,8 +1343,7 @@ one_test_erl_client(SFTP, Id, C) when SFTP==sftp ; SFTP==sftp_async -> catch ssh_sftp:stop_channel(Ch), R catch - Class:Error -> - ST = erlang:get_stacktrace(), + Class:Error:ST -> {error, {SFTP,Id,Class,Error,ST}} end. diff --git a/lib/ssh/test/ssh_options_SUITE.erl b/lib/ssh/test/ssh_options_SUITE.erl index 60d0da2a39..bf90f74324 100644 --- a/lib/ssh/test/ssh_options_SUITE.erl +++ b/lib/ssh/test/ssh_options_SUITE.erl @@ -214,7 +214,7 @@ init_per_testcase(_TestCase, Config) -> file:make_dir(UserDir), [{user_dir,UserDir}|Config]. -end_per_testcase(_TestCase, Config) -> +end_per_testcase(_TestCase, _Config) -> ssh:stop(), ok. diff --git a/lib/ssh/test/ssh_test_lib.erl b/lib/ssh/test/ssh_test_lib.erl index a1a7eebcde..1129303414 100644 --- a/lib/ssh/test/ssh_test_lib.erl +++ b/lib/ssh/test/ssh_test_lib.erl @@ -409,7 +409,7 @@ ct:log("DataDir ~p:~n ~p~n~nSystDir ~p:~n ~p~n~nUserDir ~p:~n ~p",[DataDir, file setup_ecdsa_auth_keys(Size, DataDir, UserDir). setup_eddsa(Alg, DataDir, UserDir) -> - {IdPriv, IdPub, HostPriv, HostPub} = + {IdPriv, _IdPub, HostPriv, HostPub} = case Alg of ed25519 -> {"id_ed25519", "id_ed25519.pub", "ssh_host_ed25519_key", "ssh_host_ed25519_key.pub"}; ed448 -> {"id_ed448", "id_ed448.pub", "ssh_host_ed448_key", "ssh_host_ed448_key.pub"} @@ -970,7 +970,7 @@ expected_state(_) -> false. %%%---------------------------------------------------------------- %%% Return a string with N random characters %%% -random_chars(N) -> [crypto:rand_uniform($a,$z) || _<-lists:duplicate(N,x)]. +random_chars(N) -> [($a-1)+rand:uniform($z-$a) || _<-lists:duplicate(N,x)]. create_random_dir(Config) -> diff --git a/lib/ssh/test/ssh_trpt_test_lib.erl b/lib/ssh/test/ssh_trpt_test_lib.erl index f2c9892f95..3f4df2c986 100644 --- a/lib/ssh/test/ssh_trpt_test_lib.erl +++ b/lib/ssh/test/ssh_trpt_test_lib.erl @@ -570,75 +570,6 @@ receive_binary_msg(S0=#s{}) -> -old_receive_binary_msg(S0=#s{ssh=C0=#ssh{decrypt_block_size = BlockSize, - recv_mac_size = MacSize - } - }) -> - case size(S0#s.encrypted_data_buffer) >= max(8,BlockSize) of - false -> - %% Need more bytes to decode the packet_length field - Remaining = max(8,BlockSize) - size(S0#s.encrypted_data_buffer), - receive_binary_msg( receive_wait(Remaining, S0) ); - true -> - %% Has enough bytes to decode the packet_length field - {_, <<?UINT32(PacketLen), _/binary>>, _} = - ssh_transport:decrypt_blocks(S0#s.encrypted_data_buffer, BlockSize, C0), % FIXME: BlockSize should be at least 4 - - %% FIXME: Check that ((4+PacketLen) rem BlockSize) == 0 ? - - S1 = if - PacketLen > ?SSH_MAX_PACKET_SIZE -> - fail({too_large_message,PacketLen},S0); % FIXME: disconnect - - ((4+PacketLen) rem BlockSize) =/= 0 -> - fail(bad_packet_length_modulo, S0); % FIXME: disconnect - - size(S0#s.encrypted_data_buffer) >= (4 + PacketLen + MacSize) -> - %% has the whole packet - S0; - - true -> - %% need more bytes to get have the whole packet - Remaining = (4 + PacketLen + MacSize) - size(S0#s.encrypted_data_buffer), - receive_wait(Remaining, S0) - end, - - %% Decrypt all, including the packet_length part (re-use the initial #ssh{}) - {C1, SshPacket = <<?UINT32(_),?BYTE(PadLen),Tail/binary>>, EncRest} = - ssh_transport:decrypt_blocks(S1#s.encrypted_data_buffer, PacketLen+4, C0), - - PayloadLen = PacketLen - 1 - PadLen, - <<CompressedPayload:PayloadLen/binary, _Padding:PadLen/binary>> = Tail, - - {C2, Payload} = ssh_transport:decompress(C1, CompressedPayload), - - <<Mac:MacSize/binary, Rest/binary>> = EncRest, - - case {ssh_transport:is_valid_mac(Mac, SshPacket, C2), - catch ssh_message:decode(set_prefix_if_trouble(Payload,S1))} - of - {false, _} -> fail(bad_mac,S1); - {_, {'EXIT',_}} -> fail(decode_failed,S1); - - {true, Msg} -> - C3 = case Msg of - #ssh_msg_kexinit{} -> - ssh_transport:key_init(opposite_role(C2), C2, Payload); - _ -> - C2 - end, - S2 = opt(print_messages, S1, - fun(X) when X==true;X==detail -> {"Recv~n~s~n",[format_msg(Msg)]} end), - S3 = opt(print_messages, S2, - fun(detail) -> {"decrypted bytes ~p~n",[SshPacket]} end), - S3#s{ssh = inc_recv_seq_num(C3), - encrypted_data_buffer = Rest, - return_value = Msg - } - end - end. - - set_prefix_if_trouble(Msg = <<?BYTE(Op),_/binary>>, #s{alg=#alg{kex=Kex}}) when Op == 30; Op == 31 diff --git a/lib/ssl/doc/src/notes.xml b/lib/ssl/doc/src/notes.xml index a511cb4db3..f0231da2ad 100644 --- a/lib/ssl/doc/src/notes.xml +++ b/lib/ssl/doc/src/notes.xml @@ -27,6 +27,23 @@ </header> <p>This document describes the changes made to the SSL application.</p> +<section><title>SSL 9.2.2</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + With the default BEAST Mitigation strategy for TLS 1.0 an + empty TLS fragment could be sent after a one-byte + fragment. This glitch has been fixed.</p> + <p> + Own Id: OTP-15054 Aux Id: ERIERL-346 </p> + </item> + </list> + </section> + +</section> + <section><title>SSL 9.2.1</title> <section><title>Fixed Bugs and Malfunctions</title> diff --git a/lib/ssl/src/tls_record.erl b/lib/ssl/src/tls_record.erl index 9f0c588cb6..a5c550a429 100644 --- a/lib/ssl/src/tls_record.erl +++ b/lib/ssl/src/tls_record.erl @@ -602,16 +602,18 @@ encode_fragments(_Type, _Version, _Data, CS, _CompS, _CipherS, _Seq, _CipherFrag %% 1/n-1 splitting countermeasure Rizzo/Duong-Beast, RC4 chiphers are %% not vulnerable to this attack. -split_iovec([<<FirstByte:8, Rest/binary>>|Data], Version, BCA, one_n_minus_one) +split_iovec(Data, Version, BCA, one_n_minus_one) when (BCA =/= ?RC4) andalso ({3, 1} == Version orelse {3, 0} == Version) -> - [[FirstByte]|split_iovec([Rest|Data])]; + {Part, RestData} = split_iovec(Data, 1, []), + [Part|split_iovec(RestData)]; %% 0/n splitting countermeasure for clients that are incompatible with 1/n-1 %% splitting. split_iovec(Data, Version, BCA, zero_n) when (BCA =/= ?RC4) andalso ({3, 1} == Version orelse {3, 0} == Version) -> - [<<>>|split_iovec(Data)]; + {Part, RestData} = split_iovec(Data, 0, []), + [Part|split_iovec(RestData)]; split_iovec(Data, _Version, _BCA, _BeatMitigation) -> split_iovec(Data). @@ -621,16 +623,16 @@ split_iovec(Data) -> {Part,Rest} = split_iovec(Data, ?MAX_PLAIN_TEXT_LENGTH, []), [Part|split_iovec(Rest)]. %% -split_iovec([Bin|Data], SplitSize, Acc) -> +split_iovec([Bin|Data] = Bin_Data, SplitSize, Acc) -> BinSize = byte_size(Bin), if + BinSize =< SplitSize -> + split_iovec(Data, SplitSize - BinSize, [Bin|Acc]); + SplitSize == 0 -> + {lists:reverse(Acc), Bin_Data}; SplitSize < BinSize -> {Last, Rest} = erlang:split_binary(Bin, SplitSize), - {lists:reverse(Acc, [Last]), [Rest|Data]}; - BinSize < SplitSize -> - split_iovec(Data, SplitSize - BinSize, [Bin|Acc]); - true -> % Perfect match - {lists:reverse(Acc, [Bin]), Data} + {lists:reverse(Acc, [Last]), [Rest|Data]} end; split_iovec([], _SplitSize, Acc) -> {lists:reverse(Acc),[]}. diff --git a/lib/ssl/vsn.mk b/lib/ssl/vsn.mk index c4bcc1560c..98070f794c 100644 --- a/lib/ssl/vsn.mk +++ b/lib/ssl/vsn.mk @@ -1 +1 @@ -SSL_VSN = 9.2.1 +SSL_VSN = 9.2.2 diff --git a/lib/stdlib/test/ets_SUITE.erl b/lib/stdlib/test/ets_SUITE.erl index 4640b2b228..dd49288417 100644 --- a/lib/stdlib/test/ets_SUITE.erl +++ b/lib/stdlib/test/ets_SUITE.erl @@ -4461,21 +4461,24 @@ add_loop(T, I) -> test_table_counter_concurrency(WhatToTest) -> + IntStatePrevOn = + erts_debug:set_internal_state(available_internal_state, true), ItemsToAdd = 1000000, SizeLoopSize = 1000, T = ets:new(k, [public, ordered_set, {write_concurrency, true}]), + erts_debug:set_internal_state(ets_debug_random_split_join, {T, false}), 0 = ets:info(T, size), P = self(), SpawnedSizeProcs = - [spawn(fun() -> - size_loop(T, SizeLoopSize, 0, WhatToTest), - P ! done - end) + [spawn_link(fun() -> + size_loop(T, SizeLoopSize, 0, WhatToTest), + P ! done + end) || _ <- lists:seq(1, 6)], - spawn(fun() -> - add_loop(T, ItemsToAdd), - P ! done_add - end), + spawn_link(fun() -> + add_loop(T, ItemsToAdd), + P ! done_add + end), [receive done -> ok; done_add -> ok @@ -4487,6 +4490,7 @@ test_table_counter_concurrency(WhatToTest) -> _ -> ok end, + erts_debug:set_internal_state(available_internal_state, IntStatePrevOn), ok. test_table_size_concurrency(Config) when is_list(Config) -> diff --git a/lib/tools/test/Makefile b/lib/tools/test/Makefile index 2b7b17afb3..7a0a941ccc 100644 --- a/lib/tools/test/Makefile +++ b/lib/tools/test/Makefile @@ -32,6 +32,7 @@ MODULES = \ make_SUITE \ tools_SUITE \ xref_SUITE \ + prof_bench_SUITE \ ignore_cores ERL_FILES= $(MODULES:%=%.erl) @@ -41,7 +42,7 @@ INSTALL_PROGS= $(TARGET_FILES) EMAKEFILE=Emakefile -SPEC_FILES= tools.spec +SPEC_FILES= tools.spec tools_bench.spec COVER_FILE = tools.cover # ---------------------------------------------------- diff --git a/lib/tools/test/instrument_SUITE.erl b/lib/tools/test/instrument_SUITE.erl index 33259df58f..f474669836 100644 --- a/lib/tools/test/instrument_SUITE.erl +++ b/lib/tools/test/instrument_SUITE.erl @@ -260,13 +260,18 @@ test_format(Options0, Gather, Verify) -> test_abort(Gather) -> %% There's no way for us to tell whether this actually aborted or ran to %% completion, but it might catch a few segfaults. + %% This testcase is mostly useful when run in an debug emulator as it needs + %% the modified reduction count to trigger the odd trap scenarios Runner = self(), Ref = make_ref(), spawn_opt(fun() -> - [Gather({Type, SchedId, 1, 1, Ref}) || - Type <- erlang:system_info(alloc_util_allocators), - SchedId <- lists:seq(0, erlang:system_info(schedulers))], - Runner ! Ref + [begin + Ref2 = make_ref(), + [Gather({Type, SchedId, 1, 1, Ref2}) || + Type <- erlang:system_info(alloc_util_allocators), + SchedId <- lists:seq(0, erlang:system_info(schedulers))] + end || _ <- lists:seq(1,100)], + Runner ! Ref end, [{priority, max}]), receive Ref -> ok diff --git a/lib/tools/test/prof_bench_SUITE.erl b/lib/tools/test/prof_bench_SUITE.erl new file mode 100644 index 0000000000..50d0ba9cd9 --- /dev/null +++ b/lib/tools/test/prof_bench_SUITE.erl @@ -0,0 +1,126 @@ +%% +%% %CopyrightBegin% +%% +%% 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. +%% 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(prof_bench_SUITE). + +-include_lib("common_test/include/ct_event.hrl"). + +%% Test server framework exports +-export([all/0, suite/0, init_per_suite/1, end_per_suite/1]). + +-export([overhead/1]). + +%%%--------------------------------------------------------------------- +%%% Test suites +%%%--------------------------------------------------------------------- + + +suite() -> + [{timetrap,{minutes,10}}]. + +all() -> + [overhead]. + +init_per_suite(Config) -> + case {test_server:is_native(fprof_SUITE) or + (lists:any(fun(M) -> test_server:is_native(M) end, modules())) or + (whereis(cover_server) =/= undefined), + erlang:system_info(wordsize)} + of + {true, _} -> {skip, "Native or cover code"}; + {_, 4} -> {skip, "Can't run on 32-bit as files will be large"}; + {false, 8} -> Config + end. + +end_per_suite(Config) -> + LogFile = filename:join(proplists:get_value(priv_dir, Config), "fprof.trace"), + file:delete(LogFile), + ok. + +%%%--------------------------------------------------------------------- + +%% ct:run_test([{suite, prof_bench_SUITE}]). +overhead(Config) -> + LogFile = filename:join(proplists:get_value(priv_dir, Config), "fprof.trace"), + SofsCopy = filename:join(proplists:get_value(data_dir, Config), "sofs_copy.erl"), + TC = fun() -> compile:file(SofsCopy, [binary]) end, + _Warmup = timer:tc(TC), + + {NormTime,{ok, sofs_copy, _}} = timer:tc(TC), + {FProfTime,{ok,sofs_copy,_}} = fprof:apply(timer, tc, [TC], [{file, LogFile}]), + ct:pal("FProf: ~p Norm: ~p Ratio: ~p",[FProfTime, NormTime, NormTime / FProfTime * 100]), + {ok,{EProfTime,{ok,sofs_copy,_}}} = eprof:profile([], timer, tc, [TC]), + ct:pal("EProf: ~p Norm: ~p Ratio: ~p",[EProfTime, NormTime, NormTime / EProfTime * 100]), + {CProfTime,{ok,sofs_copy,_}} = cprof_apply(timer, tc, [TC]), + ct:pal("CProf: ~p Norm: ~p Ratio: ~p",[CProfTime, NormTime, NormTime / CProfTime * 100]), + {CoverTime,{ok,sofs_copy,_}} = cover_apply(timer, tc, [TC]), + ct:pal("Cover: ~p Norm: ~p Ratio: ~p",[CoverTime, NormTime, NormTime / CoverTime * 100]), + + ct_event:notify(#event{name = benchmark_data, + data = [{name, fprof_overhead}, + {value, NormTime / FProfTime * 100}]}), + ct_event:notify(#event{name = benchmark_data, + data = [{name, eprof_overhead}, + {value, NormTime / EProfTime * 100}]}), + ct_event:notify(#event{name = benchmark_data, + data = [{name, cprof_overhead}, + {value, NormTime / CProfTime * 100}]}), + ct_event:notify(#event{name = benchmark_data, + data = [{name, cover_overhead}, + {value, NormTime / CoverTime * 100}]}). + +%% overhead(Config) -> +%% LogFile = filename:join(proplists:get_value(priv_dir, Config), "fprof.trace"), +%% SofsCopy = filename:join(proplists:get_value(data_dir, Config), "sofs_copy.erl"), +%% TC = fun() -> compile:file(SofsCopy, [binary]) end, +%% _Warmup = timer:tc(TC), + +%% [{ok,{EProfTime,{ok,sofs_copy,_}}} = eprof:profile([], timer, tc, [TC]) +%% || _ <- lists:seq(1,10)], +%% %% [fprof:apply(timer, tc, [TC], [{file, LogFile}]) || _ <- lists:seq(1,10)], +%% {FProfTime,{ok,sofs_copy,_}} = fprof:apply(timer, tc, [TC], [{file, LogFile}]), +%% {NormTime,{ok, sofs_copy, _}} = timer:tc(TC), + + %% ct:pal("FProf: ~p Norm: ~p Ratio: ~p",[FProfTime, NormTime, FProfTime / NormTime]). + +cprof_apply(M, F, A) -> + cprof:start(), + Res = apply(M, F, A), + cprof:stop(), + Res. + +cover_apply(M, F, A) -> + cover:start(), + catch cover:local_only(), + Modules = modules(), + [code:unstick_mod(Mod) || Mod <- Modules], + cover:compile_beam(Modules), + [code:stick_mod(Mod) || Mod <- Modules], + Res = apply(M, F, A), + cover:stop(), + Res. + +modules() -> + application:load(compiler), + {ok, CompilerModules} = application:get_key(compiler, modules), + %% Only cover compile a subset of the stdlib modules + StdlibModules = [erl_parse, erl_expand_records, erl_lint, gb_trees, gb_sets, sofs, + beam_lib, dict, epp, erl_anno, erl_bits, + orddict, ordsets, sets, string, unicode, unicode_util], + CompilerModules ++ StdlibModules. diff --git a/lib/tools/test/prof_bench_SUITE_data/sofs_copy.erl b/lib/tools/test/prof_bench_SUITE_data/sofs_copy.erl new file mode 100644 index 0000000000..2a9b19177e --- /dev/null +++ b/lib/tools/test/prof_bench_SUITE_data/sofs_copy.erl @@ -0,0 +1,2809 @@ +%% +%% %CopyrightBegin% +%% +%% 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. +%% 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(sofs_copy). + +-export([from_term/1, from_term/2, from_external/2, empty_set/0, + is_type/1, set/1, set/2, from_sets/1, relation/1, relation/2, + a_function/1, a_function/2, family/1, family/2, + to_external/1, type/1, to_sets/1, no_elements/1, + specification/2, union/2, intersection/2, difference/2, + symdiff/2, symmetric_partition/2, product/1, product/2, + constant_function/2, is_equal/2, is_subset/2, is_sofs_set/1, + is_set/1, is_empty_set/1, is_disjoint/2]). + +-export([union/1, intersection/1, canonical_relation/1]). + +-export([relation_to_family/1, domain/1, range/1, field/1, + relative_product/1, relative_product/2, relative_product1/2, + converse/1, image/2, inverse_image/2, strict_relation/1, + weak_relation/1, extension/3, is_a_function/1]). + +-export([composite/2, inverse/1]). + +-export([restriction/2, restriction/3, drestriction/2, drestriction/3, + substitution/2, projection/2, partition/1, partition/2, + partition/3, multiple_relative_product/2, join/4]). + +-export([family_to_relation/1, family_specification/2, + union_of_family/1, intersection_of_family/1, + family_union/1, family_intersection/1, + family_domain/1, family_range/1, family_field/1, + family_union/2, family_intersection/2, family_difference/2, + partition_family/2, family_projection/2]). + +-export([family_to_digraph/1, family_to_digraph/2, + digraph_to_family/1, digraph_to_family/2]). + +%% Shorter names of some functions. +-export([fam2rel/1, rel2fam/1]). + +-import(lists, + [any/2, append/1, flatten/1, foreach/2, + keysort/2, last/1, map/2, mapfoldl/3, member/2, merge/2, + reverse/1, reverse/2, sort/1, umerge/1, umerge/2, usort/1]). + +-compile({inline, [{family_to_relation,1}, {relation_to_family,1}]}). + +-compile({inline, [{rel,2},{a_func,2},{fam,2},{term2set,2}]}). + +-compile({inline, [{external_fun,1},{element_type,1}]}). + +-compile({inline, + [{unify_types,2}, {match_types,2}, + {test_rel,3}, {symdiff,3}, + {subst,3}]}). + +-compile({inline, [{fam_binop,3}]}). + +%% Nope, no is_member, del_member or add_member. +%% +%% See also "Naive Set Theory" by Paul R. Halmos. +%% +%% By convention, erlang:error/1 is called from exported functions. + +-define(TAG, 'Set'). +-define(ORDTAG, 'OrdSet'). + +-record(?TAG, {data = [] :: list(), type = type :: term()}). +-record(?ORDTAG, {orddata = {} :: tuple() | atom(), + ordtype = type :: term()}). + +-define(LIST(S), (S)#?TAG.data). +-define(TYPE(S), (S)#?TAG.type). +-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). + +%% Ordered sets and atoms: +-define(ORDDATA(S), (S)#?ORDTAG.orddata). +-define(ORDTYPE(S), (S)#?ORDTAG.ordtype). +-define(ORDSET(L, T), #?ORDTAG{orddata = L, ordtype = T}). +-define(IS_ORDSET(S), is_record(S, ?ORDTAG)). +-define(ATOM_TYPE, atom). +-define(IS_ATOM_TYPE(T), is_atom(T)). % true for ?ANYTYPE... + +%% When IS_SET is true: +-define(ANYTYPE, '_'). +-define(BINREL(X, Y), {X, Y}). +-define(IS_RELATION(R), is_tuple(R)). +-define(REL_ARITY(R), tuple_size(R)). +-define(REL_TYPE(I, R), element(I, R)). +-define(SET_OF(X), [X]). +-define(IS_SET_OF(X), is_list(X)). +-define(FAMILY(X, Y), ?BINREL(X, ?SET_OF(Y))). + +-export_type([anyset/0, binary_relation/0, external_set/0, a_function/0, + family/0, relation/0, set_of_sets/0, set_fun/0, spec_fun/0, + type/0]). +-export_type([ordset/0, a_set/0]). + +-type(anyset() :: ordset() | a_set()). +-type(binary_relation() :: relation()). +-type(external_set() :: term()). +-type(a_function() :: relation()). +-type(family() :: a_function()). +-opaque(ordset() :: #?ORDTAG{}). +-type(relation() :: a_set()). +-opaque(a_set() :: #?TAG{}). +-type(set_of_sets() :: a_set()). +-type(set_fun() :: pos_integer() + | {external, fun((external_set()) -> external_set())} + | fun((anyset()) -> anyset())). +-type(spec_fun() :: {external, fun((external_set()) -> boolean())} + | fun((anyset()) -> boolean())). +-type(type() :: term()). + +-type(tuple_of(_T) :: tuple()). + +%% +%% Exported functions +%% + +%%% +%%% Create sets +%%% + +-spec(from_term(Term) -> AnySet when + AnySet :: anyset(), + Term :: term()). +from_term(T) -> + Type = case T of + _ when is_list(T) -> [?ANYTYPE]; + _ -> ?ANYTYPE + end, + try setify(T, Type) + catch _:_ -> erlang:error(badarg) + end. + +-spec(from_term(Term, Type) -> AnySet when + AnySet :: anyset(), + Term :: term(), + Type :: type()). +from_term(L, T) -> + case is_type(T) of + true -> + try setify(L, T) + catch _:_ -> erlang:error(badarg) + end; + false -> + erlang:error(badarg) + end. + +-spec(from_external(ExternalSet, Type) -> AnySet when + ExternalSet :: external_set(), + AnySet :: anyset(), + Type :: type()). +from_external(L, ?SET_OF(Type)) -> + ?SET(L, Type); +from_external(T, Type) -> + ?ORDSET(T, Type). + +-spec(empty_set() -> Set when + Set :: a_set()). +empty_set() -> + ?SET([], ?ANYTYPE). + +-spec(is_type(Term) -> Bool when + Bool :: boolean(), + Term :: term()). +is_type(Atom) when ?IS_ATOM_TYPE(Atom), Atom =/= ?ANYTYPE -> + true; +is_type(?SET_OF(T)) -> + is_element_type(T); +is_type(T) when tuple_size(T) > 0 -> + is_types(tuple_size(T), T); +is_type(_T) -> + false. + +-spec(set(Terms) -> Set when + Set :: a_set(), + Terms :: [term()]). +set(L) -> + 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)) 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) -> + try setify(L, T) + catch _:_ -> erlang:error(badarg) + end; +set(_, _) -> + erlang:error(badarg). + +-spec(from_sets(ListOfSets) -> Set when + Set :: a_set(), + ListOfSets :: [anyset()]; + (TupleOfSets) -> Ordset when + Ordset :: ordset(), + TupleOfSets :: tuple_of(anyset())). +from_sets(Ss) when is_list(Ss) -> + case set_of_sets(Ss, [], ?ANYTYPE) of + {error, Error} -> + 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); + Set -> + Set + end; +from_sets(_) -> + erlang:error(badarg). + +-spec(relation(Tuples) -> Relation when + Relation :: relation(), + Tuples :: [tuple()]). +relation([]) -> + ?SET([], ?BINREL(?ATOM_TYPE, ?ATOM_TYPE)); +relation(Ts = [T | _]) when is_tuple(T) -> + try rel(Ts, tuple_size(T)) + catch _:_ -> erlang:error(badarg) + end; +relation(_) -> + erlang:error(badarg). + +-spec(relation(Tuples, Type) -> Relation when + N :: integer(), + Type :: N | type(), + Relation :: relation(), + Tuples :: [tuple()]). +relation(Ts, TS) -> + try rel(Ts, TS) + catch _:_ -> erlang:error(badarg) + end. + +-spec(a_function(Tuples) -> Function when + Function :: a_function(), + Tuples :: [tuple()]). +a_function(Ts) -> + try func(Ts, ?BINREL(?ATOM_TYPE, ?ATOM_TYPE)) of + Bad when is_atom(Bad) -> + erlang:error(Bad); + Set -> + Set + catch _:_ -> erlang:error(badarg) + end. + +-spec(a_function(Tuples, Type) -> Function when + Function :: a_function(), + Tuples :: [tuple()], + Type :: type()). +a_function(Ts, T) -> + try a_func(Ts, T) of + Bad when is_atom(Bad) -> + erlang:error(Bad); + Set -> + Set + catch _:_ -> erlang:error(badarg) + end. + +-spec(family(Tuples) -> Family when + Family :: family(), + Tuples :: [tuple()]). +family(Ts) -> + try fam2(Ts, ?FAMILY(?ATOM_TYPE, ?ATOM_TYPE)) of + Bad when is_atom(Bad) -> + erlang:error(Bad); + Set -> + Set + catch _:_ -> erlang:error(badarg) + end. + +-spec(family(Tuples, Type) -> Family when + Family :: family(), + Tuples :: [tuple()], + Type :: type()). +family(Ts, T) -> + try fam(Ts, T) of + Bad when is_atom(Bad) -> + erlang:error(Bad); + Set -> + Set + catch _:_ -> erlang:error(badarg) + end. + +%%% +%%% Functions on sets. +%%% + +-spec(to_external(AnySet) -> ExternalSet when + ExternalSet :: external_set(), + AnySet :: anyset()). +to_external(S) when ?IS_SET(S) -> + ?LIST(S); +to_external(S) when ?IS_ORDSET(S) -> + ?ORDDATA(S). + +-spec(type(AnySet) -> Type when + AnySet :: anyset(), + Type :: type()). +type(S) when ?IS_SET(S) -> + ?SET_OF(?TYPE(S)); +type(S) when ?IS_ORDSET(S) -> + ?ORDTYPE(S). + +-spec(to_sets(ASet) -> Sets when + ASet :: a_set() | ordset(), + Sets :: tuple_of(AnySet) | [AnySet], + AnySet :: anyset()). +to_sets(S) when ?IS_SET(S) -> + case ?TYPE(S) of + ?SET_OF(Type) -> list_of_sets(?LIST(S), Type, []); + Type -> list_of_ordsets(?LIST(S), Type, []) + end; +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). + +-spec(no_elements(ASet) -> NoElements when + ASet :: a_set() | ordset(), + NoElements :: non_neg_integer()). +no_elements(S) when ?IS_SET(S) -> + length(?LIST(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). + +-spec(specification(Fun, Set1) -> Set2 when + Fun :: spec_fun(), + Set1 :: a_set(), + Set2 :: a_set()). +specification(Fun, S) when ?IS_SET(S) -> + Type = ?TYPE(S), + R = case external_fun(Fun) of + false -> + spec(?LIST(S), Fun, element_type(Type), []); + XFun -> + specification(?LIST(S), XFun, []) + end, + case R of + SL when is_list(SL) -> + ?SET(SL, Type); + Bad -> + erlang:error(Bad) + end. + +-spec(union(Set1, Set2) -> Set3 when + Set1 :: a_set(), + Set2 :: a_set(), + 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); + Type -> ?SET(umerge(?LIST(S1), ?LIST(S2)), Type) + end. + +-spec(intersection(Set1, Set2) -> Set3 when + Set1 :: a_set(), + Set2 :: a_set(), + 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); + Type -> ?SET(intersection(?LIST(S1), ?LIST(S2), []), Type) + end. + +-spec(difference(Set1, Set2) -> Set3 when + Set1 :: a_set(), + Set2 :: a_set(), + 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); + Type -> ?SET(difference(?LIST(S1), ?LIST(S2), []), Type) + end. + +-spec(symdiff(Set1, Set2) -> Set3 when + Set1 :: a_set(), + Set2 :: a_set(), + 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); + Type -> ?SET(symdiff(?LIST(S1), ?LIST(S2), []), Type) + end. + +-spec(symmetric_partition(Set1, Set2) -> {Set3, Set4, Set5} when + Set1 :: a_set(), + Set2 :: a_set(), + Set3 :: a_set(), + Set4 :: a_set(), + 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); + Type -> sympart(?LIST(S1), ?LIST(S2), [], [], [], Type) + end. + +-spec(product(Set1, Set2) -> BinRel when + BinRel :: binary_relation(), + Set1 :: a_set(), + Set2 :: a_set()). +product(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> + if + ?TYPE(S1) =:= ?ANYTYPE -> S1; + ?TYPE(S2) =:= ?ANYTYPE -> S2; + true -> + F = fun(E) -> {0, E} end, + T = ?BINREL(?TYPE(S1), ?TYPE(S2)), + ?SET(relprod(map(F, ?LIST(S1)), map(F, ?LIST(S2))), T) + end. + +-spec(product(TupleOfSets) -> Relation when + Relation :: relation(), + TupleOfSets :: tuple_of(a_set())). +product({S1, S2}) -> + product(S1, S2); +product(T) when is_tuple(T) -> + Ss = tuple_to_list(T), + try sets_to_list(Ss) of + [] -> + erlang:error(badarg); + L -> + Type = types(Ss, []), + case member([], L) of + true -> + empty_set(); + false -> + ?SET(reverse(prod(L, [], [])), Type) + end + catch _:_ -> erlang:error(badarg) + end. + +-spec(constant_function(Set, AnySet) -> Function when + AnySet :: anyset(), + Function :: a_function(), + Set :: a_set()). +constant_function(S, E) when ?IS_SET(S) -> + case {?TYPE(S), is_sofs_set(E)} of + {?ANYTYPE, true} -> S; + {Type, true} -> + NType = ?BINREL(Type, type(E)), + ?SET(constant_function(?LIST(S), to_external(E), []), NType); + _ -> erlang:error(badarg) + end; +constant_function(S, _) when ?IS_ORDSET(S) -> + erlang:error(badarg). + +-spec(is_equal(AnySet1, AnySet2) -> Bool when + AnySet1 :: anyset(), + AnySet2 :: anyset(), + Bool :: boolean()). +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) + 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) + end; +is_equal(S1, S2) when ?IS_SET(S1), ?IS_ORDSET(S2) -> + erlang:error(type_mismatch); +is_equal(S1, S2) when ?IS_ORDSET(S1), ?IS_SET(S2) -> + erlang:error(type_mismatch). + +-spec(is_subset(Set1, Set2) -> Bool when + Bool :: boolean(), + Set1 :: a_set(), + Set2 :: a_set()). +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) + end. + +-spec(is_sofs_set(Term) -> Bool when + Bool :: boolean(), + Term :: term()). +is_sofs_set(S) when ?IS_SET(S) -> + true; +is_sofs_set(S) when ?IS_ORDSET(S) -> + true; +is_sofs_set(_S) -> + false. + +-spec(is_set(AnySet) -> Bool when + AnySet :: anyset(), + Bool :: boolean()). +is_set(S) when ?IS_SET(S) -> + true; +is_set(S) when ?IS_ORDSET(S) -> + false. + +-spec(is_empty_set(AnySet) -> Bool when + AnySet :: anyset(), + Bool :: boolean()). +is_empty_set(S) when ?IS_SET(S) -> + ?LIST(S) =:= []; +is_empty_set(S) when ?IS_ORDSET(S) -> + false. + +-spec(is_disjoint(Set1, Set2) -> Bool when + Bool :: boolean(), + Set1 :: a_set(), + Set2 :: a_set()). +is_disjoint(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> + case match_types(?TYPE(S1), ?TYPE(S2)) of + true -> + case ?LIST(S1) of + [] -> true; + [A | As] -> disjoint(?LIST(S2), A, As) + end; + false -> erlang:error(type_mismatch) + end. + +%%% +%%% Functions on set-of-sets. +%%% + +-spec(union(SetOfSets) -> Set when + Set :: a_set(), + SetOfSets :: set_of_sets()). +union(Sets) when ?IS_SET(Sets) -> + case ?TYPE(Sets) of + ?SET_OF(Type) -> ?SET(lunion(?LIST(Sets)), Type); + ?ANYTYPE -> Sets; + _ -> erlang:error(badarg) + end. + +-spec(intersection(SetOfSets) -> Set when + Set :: a_set(), + SetOfSets :: set_of_sets()). +intersection(Sets) when ?IS_SET(Sets) -> + case ?LIST(Sets) of + [] -> erlang:error(badarg); + [L | Ls] -> + case ?TYPE(Sets) of + ?SET_OF(Type) -> + ?SET(lintersection(Ls, L), Type); + _ -> erlang:error(badarg) + end + end. + +-spec(canonical_relation(SetOfSets) -> BinRel when + BinRel :: binary_relation(), + SetOfSets :: set_of_sets()). +canonical_relation(Sets) when ?IS_SET(Sets) -> + ST = ?TYPE(Sets), + case ST of + ?SET_OF(?ANYTYPE) -> empty_set(); + ?SET_OF(Type) -> + ?SET(can_rel(?LIST(Sets), []), ?BINREL(Type, ST)); + ?ANYTYPE -> Sets; + _ -> erlang:error(badarg) + end. + +%%% +%%% Functions on binary relations only. +%%% + +-spec(rel2fam(BinRel) -> Family when + Family :: family(), + BinRel :: binary_relation()). +rel2fam(R) -> + relation_to_family(R). + +-spec(relation_to_family(BinRel) -> Family when + Family :: family(), + BinRel :: binary_relation()). +%% Inlined. +relation_to_family(R) when ?IS_SET(R) -> + case ?TYPE(R) of + ?BINREL(DT, RT) -> + ?SET(rel2family(?LIST(R)), ?FAMILY(DT, RT)); + ?ANYTYPE -> R; + _Else -> erlang:error(badarg) + end. + +-spec(domain(BinRel) -> Set when + BinRel :: binary_relation(), + Set :: a_set()). +domain(R) when ?IS_SET(R) -> + case ?TYPE(R) of + ?BINREL(DT, _) -> ?SET(dom(?LIST(R)), DT); + ?ANYTYPE -> R; + _Else -> erlang:error(badarg) + end. + +-spec(range(BinRel) -> Set when + BinRel :: binary_relation(), + Set :: a_set()). +range(R) when ?IS_SET(R) -> + case ?TYPE(R) of + ?BINREL(_, RT) -> ?SET(ran(?LIST(R), []), RT); + ?ANYTYPE -> R; + _ -> erlang:error(badarg) + end. + +-spec(field(BinRel) -> Set when + BinRel :: binary_relation(), + Set :: a_set()). +%% In "Introduction to LOGIC", Suppes defines the field of a binary +%% relation to be the union of the domain and the range (or +%% counterdomain). +field(R) -> + union(domain(R), range(R)). + +-spec(relative_product(ListOfBinRels) -> BinRel2 when + ListOfBinRels :: [BinRel, ...], + BinRel :: binary_relation(), + BinRel2 :: binary_relation()). +%% The following clause is kept for backward compatibility. +%% The list is due to Dialyzer's specs. +relative_product(RT) when is_tuple(RT) -> + relative_product(tuple_to_list(RT)); +relative_product(RL) when is_list(RL) -> + case relprod_n(RL, foo, false, false) of + {error, Reason} -> + erlang:error(Reason); + Reply -> + Reply + end. + +-spec(relative_product(ListOfBinRels, BinRel1) -> BinRel2 when + ListOfBinRels :: [BinRel, ...], + BinRel :: binary_relation(), + BinRel1 :: binary_relation(), + BinRel2 :: binary_relation(); + (BinRel1, BinRel2) -> BinRel3 when + BinRel1 :: binary_relation(), + BinRel2 :: binary_relation(), + BinRel3 :: binary_relation()). +relative_product(R1, R2) when ?IS_SET(R1), ?IS_SET(R2) -> + relative_product1(converse(R1), R2); +%% The following clause is kept for backward compatibility. +%% The list is due to Dialyzer's specs. +relative_product(RT, R) when is_tuple(RT), ?IS_SET(R) -> + relative_product(tuple_to_list(RT), R); +relative_product(RL, R) when is_list(RL), ?IS_SET(R) -> + EmptyR = case ?TYPE(R) of + ?BINREL(_, _) -> ?LIST(R) =:= []; + ?ANYTYPE -> true; + _ -> erlang:error(badarg) + end, + case relprod_n(RL, R, EmptyR, true) of + {error, Reason} -> + erlang:error(Reason); + Reply -> + Reply + end. + +-spec(relative_product1(BinRel1, BinRel2) -> BinRel3 when + BinRel1 :: binary_relation(), + BinRel2 :: binary_relation(), + BinRel3 :: binary_relation()). +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) + end, + {DTR2, RTR2} = case ?TYPE(R2) of + ?BINREL(_, _) = R2T -> R2T; + ?ANYTYPE -> {?ANYTYPE, ?ANYTYPE}; + _ -> 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) + end. + +-spec(converse(BinRel1) -> BinRel2 when + BinRel1 :: binary_relation(), + BinRel2 :: binary_relation()). +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) + end. + +-spec(image(BinRel, Set1) -> Set2 when + BinRel :: binary_relation(), + Set1 :: a_set(), + Set2 :: a_set()). +image(R, S) when ?IS_SET(R), ?IS_SET(S) -> + case ?TYPE(R) of + ?BINREL(DT, RT) -> + case match_types(DT, ?TYPE(S)) of + true -> + ?SET(usort(restrict(?LIST(S), ?LIST(R))), RT); + false -> + erlang:error(type_mismatch) + end; + ?ANYTYPE -> R; + _ -> erlang:error(badarg) + end. + +-spec(inverse_image(BinRel, Set1) -> Set2 when + BinRel :: binary_relation(), + Set1 :: a_set(), + Set2 :: a_set()). +inverse_image(R, S) when ?IS_SET(R), ?IS_SET(S) -> + case ?TYPE(R) of + ?BINREL(DT, RT) -> + case match_types(RT, ?TYPE(S)) of + true -> + NL = restrict(?LIST(S), converse(?LIST(R), [])), + ?SET(usort(NL), DT); + false -> + erlang:error(type_mismatch) + end; + ?ANYTYPE -> R; + _ -> erlang:error(badarg) + end. + +-spec(strict_relation(BinRel1) -> BinRel2 when + BinRel1 :: binary_relation(), + BinRel2 :: binary_relation()). +strict_relation(R) when ?IS_SET(R) -> + case ?TYPE(R) of + Type = ?BINREL(_, _) -> + ?SET(strict(?LIST(R), []), Type); + ?ANYTYPE -> R; + _ -> erlang:error(badarg) + end. + +-spec(weak_relation(BinRel1) -> BinRel2 when + BinRel1 :: binary_relation(), + BinRel2 :: binary_relation()). +weak_relation(R) when ?IS_SET(R) -> + case ?TYPE(R) of + ?BINREL(DT, RT) -> + case unify_types(DT, RT) of + [] -> + erlang:error(badarg); + Type -> + ?SET(weak(?LIST(R)), ?BINREL(Type, Type)) + end; + ?ANYTYPE -> R; + _ -> erlang:error(badarg) + end. + +-spec(extension(BinRel1, Set, AnySet) -> BinRel2 when + AnySet :: anyset(), + BinRel1 :: binary_relation(), + BinRel2 :: binary_relation(), + Set :: a_set()). +extension(R, S, E) when ?IS_SET(R), ?IS_SET(S) -> + case {?TYPE(R), ?TYPE(S), is_sofs_set(E)} of + {T=?BINREL(DT, RT), ST, true} -> + case match_types(DT, ST) and match_types(RT, type(E)) of + false -> + erlang:error(type_mismatch); + true -> + RL = ?LIST(R), + case extc([], ?LIST(S), to_external(E), RL) of + [] -> + R; + L -> + ?SET(merge(RL, reverse(L)), T) + end + end; + {?ANYTYPE, ?ANYTYPE, true} -> + R; + {?ANYTYPE, ST, true} -> + case type(E) of + ?SET_OF(?ANYTYPE) -> + R; + ET -> + ?SET([], ?BINREL(ST, ET)) + end; + {_, _, true} -> + erlang:error(badarg) + end. + +-spec(is_a_function(BinRel) -> Bool when + Bool :: boolean(), + BinRel :: binary_relation()). +is_a_function(R) when ?IS_SET(R) -> + case ?TYPE(R) of + ?BINREL(_, _) -> + case ?LIST(R) of + [] -> true; + [{V,_} | Es] -> is_a_func(Es, V) + end; + ?ANYTYPE -> true; + _ -> erlang:error(badarg) + end. + +-spec(restriction(BinRel1, Set) -> BinRel2 when + BinRel1 :: binary_relation(), + BinRel2 :: binary_relation(), + Set :: a_set()). +restriction(Relation, Set) -> + restriction(1, Relation, Set). + +-spec(drestriction(BinRel1, Set) -> BinRel2 when + BinRel1 :: binary_relation(), + BinRel2 :: binary_relation(), + Set :: a_set()). +drestriction(Relation, Set) -> + drestriction(1, Relation, Set). + +%%% +%%% Functions on functions only. +%%% + +-spec(composite(Function1, Function2) -> Function3 when + Function1 :: a_function(), + Function2 :: a_function(), + Function3 :: a_function()). +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) + end, + ?BINREL(DTF2, RTF2) = case ?TYPE(Fn2) of + ?BINREL(_, _) = F2T -> F2T; + ?ANYTYPE -> {?ANYTYPE, ?ANYTYPE}; + _ -> erlang:error(badarg) + end, + case match_types(RTF1, DTF2) of + true when DTF1 =:= ?ANYTYPE -> Fn1; + true when DTF2 =:= ?ANYTYPE -> Fn2; + true -> + case comp(?LIST(Fn1), ?LIST(Fn2)) of + SL when is_list(SL) -> + ?SET(sort(SL), ?BINREL(DTF1, RTF2)); + Bad -> + erlang:error(Bad) + end; + false -> erlang:error(type_mismatch) + end. + +-spec(inverse(Function1) -> Function2 when + Function1 :: a_function(), + Function2 :: a_function()). +inverse(Fn) when ?IS_SET(Fn) -> + case ?TYPE(Fn) of + ?BINREL(DT, RT) -> + case inverse1(?LIST(Fn)) of + SL when is_list(SL) -> + ?SET(SL, ?BINREL(RT, DT)); + Bad -> + erlang:error(Bad) + end; + ?ANYTYPE -> Fn; + _ -> erlang:error(badarg) + end. + +%%% +%%% Functions on relations (binary or other). +%%% + +-spec(restriction(SetFun, Set1, Set2) -> Set3 when + SetFun :: set_fun(), + Set1 :: a_set(), + Set2 :: a_set(), + Set3 :: a_set()). +%% Equivalent to range(restriction(inverse(substitution(Fun, S1)), S2)). +restriction(I, R, S) when is_integer(I), ?IS_SET(R), ?IS_SET(S) -> + RT = ?TYPE(R), + ST = ?TYPE(S), + case check_for_sort(RT, I) of + empty -> + R; + error -> + erlang:error(badarg); + Sort -> + RL = ?LIST(R), + case {match_types(?REL_TYPE(I, RT), ST), ?LIST(S)} of + {true, _SL} when RL =:= [] -> + R; + {true, []} -> + ?SET([], RT); + {true, [E | Es]} when Sort =:= false -> % I =:= 1 + ?SET(reverse(restrict_n(I, RL, E, Es, [])), RT); + {true, [E | Es]} -> + ?SET(sort(restrict_n(I, keysort(I, RL), E, Es, [])), RT); + {false, _SL} -> + erlang:error(type_mismatch) + end + end; +restriction(SetFun, S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> + Type1 = ?TYPE(S1), + Type2 = ?TYPE(S2), + SL1 = ?LIST(S1), + case external_fun(SetFun) of + false when Type2 =:= ?ANYTYPE -> + S2; + false -> + case subst(SL1, SetFun, element_type(Type1)) of + {NSL, NewType} -> % NewType can be ?ANYTYPE + case match_types(NewType, Type2) of + true -> + NL = sort(restrict(?LIST(S2), converse(NSL, []))), + ?SET(NL, Type1); + false -> + erlang:error(type_mismatch) + end; + Bad -> + erlang:error(Bad) + end; + _ when Type1 =:= ?ANYTYPE -> + S1; + _XFun when ?IS_SET_OF(Type1) -> + erlang:error(badarg); + XFun -> + FunT = XFun(Type1), + 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) + end + catch _:_ -> erlang:error(badarg) + end + end. + +-spec(drestriction(SetFun, Set1, Set2) -> Set3 when + SetFun :: set_fun(), + Set1 :: a_set(), + Set2 :: a_set(), + Set3 :: a_set()). +drestriction(I, R, S) when is_integer(I), ?IS_SET(R), ?IS_SET(S) -> + RT = ?TYPE(R), + ST = ?TYPE(S), + case check_for_sort(RT, I) of + empty -> + R; + error -> + erlang:error(badarg); + Sort -> + RL = ?LIST(R), + case {match_types(?REL_TYPE(I, RT), ST), ?LIST(S)} of + {true, []} -> + R; + {true, _SL} when RL =:= [] -> + R; + {true, [E | Es]} when Sort =:= false -> % I =:= 1 + ?SET(diff_restrict_n(I, RL, E, Es, []), RT); + {true, [E | Es]} -> + ?SET(diff_restrict_n(I, keysort(I, RL), E, Es, []), RT); + {false, _SL} -> + erlang:error(type_mismatch) + end + end; +drestriction(SetFun, S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> + Type1 = ?TYPE(S1), + Type2 = ?TYPE(S2), + SL1 = ?LIST(S1), + case external_fun(SetFun) of + false when Type2 =:= ?ANYTYPE -> + S1; + false -> + case subst(SL1, SetFun, element_type(Type1)) of + {NSL, NewType} -> % NewType can be ?ANYTYPE + case match_types(NewType, Type2) of + true -> + SL2 = ?LIST(S2), + NL = sort(diff_restrict(SL2, converse(NSL, []))), + ?SET(NL, Type1); + false -> + erlang:error(type_mismatch) + end; + Bad -> + erlang:error(Bad) + end; + _ when Type1 =:= ?ANYTYPE -> + S1; + _XFun when ?IS_SET_OF(Type1) -> + erlang:error(badarg); + XFun -> + FunT = XFun(Type1), + try check_fun(Type1, XFun, FunT) of + Sort -> + case match_types(FunT, Type2) of + true -> + R1 = inverse_substitution(SL1, XFun, Sort), + SL2 = ?LIST(S2), + ?SET(sort(Sort, diff_restrict(SL2, R1)), Type1); + false -> + erlang:error(type_mismatch) + end + catch _:_ -> erlang:error(badarg) + end + end. + +-spec(projection(SetFun, Set1) -> Set2 when + SetFun :: set_fun(), + Set1 :: a_set(), + Set2 :: a_set()). +projection(I, Set) when is_integer(I), ?IS_SET(Set) -> + Type = ?TYPE(Set), + case check_for_sort(Type, I) of + empty -> + Set; + error -> + erlang:error(badarg); + _ when I =:= 1 -> + ?SET(projection1(?LIST(Set)), ?REL_TYPE(I, Type)); + _ -> + ?SET(projection_n(?LIST(Set), I, []), ?REL_TYPE(I, Type)) + end; +projection(Fun, Set) -> + range(substitution(Fun, Set)). + +-spec(substitution(SetFun, Set1) -> Set2 when + SetFun :: set_fun(), + Set1 :: a_set(), + Set2 :: a_set()). +substitution(I, Set) when is_integer(I), ?IS_SET(Set) -> + Type = ?TYPE(Set), + case check_for_sort(Type, I) of + empty -> + Set; + error -> + erlang:error(badarg); + _Sort -> + NType = ?REL_TYPE(I, Type), + NSL = substitute_element(?LIST(Set), I, []), + ?SET(NSL, ?BINREL(Type, NType)) + end; +substitution(SetFun, Set) when ?IS_SET(Set) -> + Type = ?TYPE(Set), + L = ?LIST(Set), + case external_fun(SetFun) of + false when L =/= [] -> + case subst(L, SetFun, element_type(Type)) of + {SL, NewType} -> + ?SET(reverse(SL), ?BINREL(Type, NewType)); + Bad -> + erlang:error(Bad) + end; + false -> + empty_set(); + _ when Type =:= ?ANYTYPE -> + empty_set(); + _XFun when ?IS_SET_OF(Type) -> + erlang:error(badarg); + XFun -> + FunT = XFun(Type), + try check_fun(Type, XFun, FunT) of + _Sort -> + SL = substitute(L, XFun, []), + ?SET(SL, ?BINREL(Type, FunT)) + catch _:_ -> erlang:error(badarg) + end + end. + +-spec(partition(SetOfSets) -> Partition when + SetOfSets :: set_of_sets(), + Partition :: a_set()). +partition(Sets) -> + F1 = relation_to_family(canonical_relation(Sets)), + F2 = relation_to_family(converse(F1)), + range(F2). + +-spec(partition(SetFun, Set) -> Partition when + SetFun :: set_fun(), + Partition :: a_set(), + Set :: a_set()). +partition(I, Set) when is_integer(I), ?IS_SET(Set) -> + Type = ?TYPE(Set), + case check_for_sort(Type, I) of + empty -> + Set; + error -> + erlang:error(badarg); + false -> % I =:= 1 + ?SET(partition_n(I, ?LIST(Set)), ?SET_OF(Type)); + true -> + ?SET(partition_n(I, keysort(I, ?LIST(Set))), ?SET_OF(Type)) + end; +partition(Fun, Set) -> + range(partition_family(Fun, Set)). + +-spec(partition(SetFun, Set1, Set2) -> {Set3, Set4} when + SetFun :: set_fun(), + Set1 :: a_set(), + Set2 :: a_set(), + Set3 :: a_set(), + Set4 :: a_set()). +partition(I, R, S) when is_integer(I), ?IS_SET(R), ?IS_SET(S) -> + RT = ?TYPE(R), + ST = ?TYPE(S), + case check_for_sort(RT, I) of + empty -> + {R, R}; + error -> + erlang:error(badarg); + Sort -> + RL = ?LIST(R), + case {match_types(?REL_TYPE(I, RT), ST), ?LIST(S)} of + {true, _SL} when RL =:= [] -> + {R, R}; + {true, []} -> + {?SET([], RT), R}; + {true, [E | Es]} when Sort =:= false -> % I =:= 1 + [L1 | L2] = partition3_n(I, RL, E, Es, [], []), + {?SET(L1, RT), ?SET(L2, RT)}; + {true, [E | Es]} -> + [L1 | L2] = partition3_n(I, keysort(I,RL), E, Es, [], []), + {?SET(L1, RT), ?SET(L2, RT)}; + {false, _SL} -> + erlang:error(type_mismatch) + end + end; +partition(SetFun, S1, S2) when ?IS_SET(S1), ?IS_SET(S2) -> + Type1 = ?TYPE(S1), + Type2 = ?TYPE(S2), + SL1 = ?LIST(S1), + case external_fun(SetFun) of + false when Type2 =:= ?ANYTYPE -> + {S2, S1}; + false -> + case subst(SL1, SetFun, element_type(Type1)) of + {NSL, NewType} -> % NewType can be ?ANYTYPE + case match_types(NewType, Type2) of + true -> + R1 = converse(NSL, []), + [L1 | L2] = partition3(?LIST(S2), R1), + {?SET(sort(L1), Type1), ?SET(sort(L2), Type1)}; + false -> + erlang:error(type_mismatch) + end; + Bad -> + erlang:error(Bad) + end; + _ when Type1 =:= ?ANYTYPE -> + {S1, S1}; + _XFun when ?IS_SET_OF(Type1) -> + erlang:error(badarg); + XFun -> + FunT = XFun(Type1), + try check_fun(Type1, XFun, FunT) of + Sort -> + case match_types(FunT, Type2) of + true -> + R1 = inverse_substitution(SL1, XFun, Sort), + [L1 | L2] = partition3(?LIST(S2), R1), + {?SET(sort(L1), Type1), ?SET(sort(L2), Type1)}; + false -> + erlang:error(type_mismatch) + end + catch _:_ -> erlang:error(badarg) + end + end. + +-spec(multiple_relative_product(TupleOfBinRels, BinRel1) -> BinRel2 when + TupleOfBinRels :: tuple_of(BinRel), + BinRel :: binary_relation(), + BinRel1 :: binary_relation(), + BinRel2 :: binary_relation()). +multiple_relative_product(T, R) when is_tuple(T), ?IS_SET(R) -> + case test_rel(R, tuple_size(T), eq) of + true when ?TYPE(R) =:= ?ANYTYPE -> + empty_set(); + true -> + MProd = mul_relprod(tuple_to_list(T), 1, R), + relative_product(MProd); + false -> + erlang:error(badarg) + end. + +-spec(join(Relation1, I, Relation2, J) -> Relation3 when + Relation1 :: relation(), + Relation2 :: relation(), + Relation3 :: relation(), + I :: pos_integer(), + J :: pos_integer()). +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); + true when ?TYPE(R1) =:= ?ANYTYPE -> R1; + true when ?TYPE(R2) =:= ?ANYTYPE -> R2; + true -> + L1 = ?LIST(raise_element(R1, I1)), + L2 = ?LIST(raise_element(R2, I2)), + T = relprod1(L1, L2), + F = case (I1 =:= 1) and (I2 =:= 1) of + true -> + fun({X,Y}) -> join_element(X, Y) end; + false -> + fun({X,Y}) -> + list_to_tuple(join_element(X, Y, I2)) + end + end, + ?SET(replace(T, F, []), F({?TYPE(R1), ?TYPE(R2)})) + end. + +%% Inlined. +test_rel(R, I, C) -> + case ?TYPE(R) of + Rel when ?IS_RELATION(Rel), C =:= eq, I =:= ?REL_ARITY(Rel) -> true; + Rel when ?IS_RELATION(Rel), C =:= lte, I>=1, I =< ?REL_ARITY(Rel) -> + true; + ?ANYTYPE -> true; + _ -> false + end. + +%%% +%%% Family functions +%%% + +-spec(fam2rel(Family) -> BinRel when + Family :: family(), + BinRel :: binary_relation()). +fam2rel(F) -> + family_to_relation(F). + +-spec(family_to_relation(Family) -> BinRel when + Family :: family(), + BinRel :: binary_relation()). +%% Inlined. +family_to_relation(F) when ?IS_SET(F) -> + case ?TYPE(F) of + ?FAMILY(DT, RT) -> + ?SET(family2rel(?LIST(F), []), ?BINREL(DT, RT)); + ?ANYTYPE -> F; + _ -> erlang:error(badarg) + end. + +-spec(family_specification(Fun, Family1) -> Family2 when + Fun :: spec_fun(), + Family1 :: family(), + Family2 :: family()). +family_specification(Fun, F) when ?IS_SET(F) -> + case ?TYPE(F) of + ?FAMILY(_DT, Type) = FType -> + R = case external_fun(Fun) of + false -> + fam_spec(?LIST(F), Fun, Type, []); + XFun -> + fam_specification(?LIST(F), XFun, []) + end, + case R of + SL when is_list(SL) -> + ?SET(SL, FType); + Bad -> + erlang:error(Bad) + end; + ?ANYTYPE -> F; + _ -> erlang:error(badarg) + end. + +-spec(union_of_family(Family) -> Set when + Family :: family(), + Set :: a_set()). +union_of_family(F) when ?IS_SET(F) -> + case ?TYPE(F) of + ?FAMILY(_DT, Type) -> + ?SET(un_of_fam(?LIST(F), []), Type); + ?ANYTYPE -> F; + _ -> erlang:error(badarg) + end. + +-spec(intersection_of_family(Family) -> Set when + Family :: family(), + Set :: a_set()). +intersection_of_family(F) when ?IS_SET(F) -> + case ?TYPE(F) of + ?FAMILY(_DT, Type) -> + case int_of_fam(?LIST(F)) of + FU when is_list(FU) -> + ?SET(FU, Type); + Bad -> + erlang:error(Bad) + end; + _ -> erlang:error(badarg) + end. + +-spec(family_union(Family1) -> Family2 when + Family1 :: family(), + Family2 :: family()). +family_union(F) when ?IS_SET(F) -> + case ?TYPE(F) of + ?FAMILY(DT, ?SET_OF(Type)) -> + ?SET(fam_un(?LIST(F), []), ?FAMILY(DT, Type)); + ?ANYTYPE -> F; + _ -> erlang:error(badarg) + end. + +-spec(family_intersection(Family1) -> Family2 when + Family1 :: family(), + Family2 :: family()). +family_intersection(F) when ?IS_SET(F) -> + case ?TYPE(F) of + ?FAMILY(DT, ?SET_OF(Type)) -> + case fam_int(?LIST(F), []) of + FU when is_list(FU) -> + ?SET(FU, ?FAMILY(DT, Type)); + Bad -> + erlang:error(Bad) + end; + ?ANYTYPE -> F; + _ -> erlang:error(badarg) + end. + +-spec(family_domain(Family1) -> Family2 when + Family1 :: family(), + Family2 :: family()). +family_domain(F) when ?IS_SET(F) -> + case ?TYPE(F) of + ?FAMILY(FDT, ?BINREL(DT, _)) -> + ?SET(fam_dom(?LIST(F), []), ?FAMILY(FDT, DT)); + ?ANYTYPE -> F; + ?FAMILY(_, ?ANYTYPE) -> F; + _ -> erlang:error(badarg) + end. + +-spec(family_range(Family1) -> Family2 when + Family1 :: family(), + Family2 :: family()). +family_range(F) when ?IS_SET(F) -> + case ?TYPE(F) of + ?FAMILY(DT, ?BINREL(_, RT)) -> + ?SET(fam_ran(?LIST(F), []), ?FAMILY(DT, RT)); + ?ANYTYPE -> F; + ?FAMILY(_, ?ANYTYPE) -> F; + _ -> erlang:error(badarg) + end. + +-spec(family_field(Family1) -> Family2 when + Family1 :: family(), + Family2 :: family()). +family_field(F) -> + family_union(family_domain(F), family_range(F)). + +-spec(family_union(Family1, Family2) -> Family3 when + Family1 :: family(), + Family2 :: family(), + Family3 :: family()). +family_union(F1, F2) -> + fam_binop(F1, F2, fun fam_union/3). + +-spec(family_intersection(Family1, Family2) -> Family3 when + Family1 :: family(), + Family2 :: family(), + Family3 :: family()). +family_intersection(F1, F2) -> + fam_binop(F1, F2, fun fam_intersect/3). + +-spec(family_difference(Family1, Family2) -> Family3 when + Family1 :: family(), + Family2 :: family(), + Family3 :: family()). +family_difference(F1, F2) -> + fam_binop(F1, F2, fun fam_difference/3). + +%% Inlined. +fam_binop(F1, F2, FF) when ?IS_SET(F1), ?IS_SET(F2) -> + case unify_types(?TYPE(F1), ?TYPE(F2)) of + [] -> + erlang:error(type_mismatch); + ?ANYTYPE -> + F1; + Type = ?FAMILY(_, _) -> + ?SET(FF(?LIST(F1), ?LIST(F2), []), Type); + _ -> erlang:error(badarg) + end. + +-spec(partition_family(SetFun, Set) -> Family when + Family :: family(), + SetFun :: set_fun(), + Set :: a_set()). +partition_family(I, Set) when is_integer(I), ?IS_SET(Set) -> + Type = ?TYPE(Set), + case check_for_sort(Type, I) of + empty -> + Set; + error -> + erlang:error(badarg); + false -> % when I =:= 1 + ?SET(fam_partition_n(I, ?LIST(Set)), + ?BINREL(?REL_TYPE(I, Type), ?SET_OF(Type))); + true -> + ?SET(fam_partition_n(I, keysort(I, ?LIST(Set))), + ?BINREL(?REL_TYPE(I, Type), ?SET_OF(Type))) + end; +partition_family(SetFun, Set) when ?IS_SET(Set) -> + Type = ?TYPE(Set), + SL = ?LIST(Set), + case external_fun(SetFun) of + false when SL =/= [] -> + case subst(SL, SetFun, element_type(Type)) of + {NSL, NewType} -> + P = fam_partition(converse(NSL, []), true), + ?SET(reverse(P), ?BINREL(NewType, ?SET_OF(Type))); + Bad -> + erlang:error(Bad) + end; + false -> + empty_set(); + _ when Type =:= ?ANYTYPE -> + empty_set(); + _XFun when ?IS_SET_OF(Type) -> + erlang:error(badarg); + XFun -> + DType = XFun(Type), + 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. + +-spec(family_projection(SetFun, Family1) -> Family2 when + SetFun :: set_fun(), + Family1 :: family(), + Family2 :: family()). +family_projection(SetFun, F) when ?IS_SET(F) -> + case ?TYPE(F) of + ?FAMILY(_, _) when [] =:= ?LIST(F) -> + empty_set(); + ?FAMILY(DT, Type) -> + case external_fun(SetFun) of + false -> + case fam_proj(?LIST(F), SetFun, Type, ?ANYTYPE, []) of + {SL, NewType} -> + ?SET(SL, ?BINREL(DT, NewType)); + Bad -> + erlang:error(Bad) + end; + _ -> + erlang:error(badarg) + end; + ?ANYTYPE -> F; + _ -> erlang:error(badarg) + end. + +%%% +%%% Digraph functions +%%% + +-spec(family_to_digraph(Family) -> Graph when + Graph :: digraph:graph(), + Family :: family()). +family_to_digraph(F) when ?IS_SET(F) -> + case ?TYPE(F) of + ?FAMILY(_, _) -> fam2digraph(F, digraph:new()); + ?ANYTYPE -> digraph:new(); + _Else -> erlang:error(badarg) + end. + +-spec(family_to_digraph(Family, GraphType) -> Graph when + Graph :: digraph:graph(), + Family :: family(), + GraphType :: [digraph:d_type()]). +family_to_digraph(F, Type) when ?IS_SET(F) -> + case ?TYPE(F) of + ?FAMILY(_, _) -> ok; + ?ANYTYPE -> ok; + _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); + _ -> + G + end + catch + error:badarg -> erlang:error(badarg) + end. + +-spec(digraph_to_family(Graph) -> Family when + Graph :: digraph:graph(), + Family :: family()). +digraph_to_family(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 + Graph :: digraph:graph(), + Family :: family(), + Type :: type()). +digraph_to_family(G, T) -> + case {is_type(T), T} of + {true, ?SET_OF(?FAMILY(_,_) = Type)} -> + try digraph_family(G) of + L -> ?SET(L, Type) + catch _:_ -> erlang:error(badarg) + end; + _ -> + erlang:error(badarg) + end. + +%% +%% Local functions +%% + +%% Type = OrderedSetType +%% | SetType +%% | atom() except '_' +%% OrderedSetType = {Type, ..., Type} +%% SetType = [ElementType] % list of exactly one element +%% ElementType = '_' % any type (implies empty set) +%% | Type + +is_types(0, _T) -> + true; +is_types(I, T) -> + case is_type(?REL_TYPE(I, T)) of + true -> is_types(I-1, T); + false -> false + end. + +is_element_type(?ANYTYPE) -> + true; +is_element_type(T) -> + is_type(T). + +set_of_sets([S | Ss], L, T0) when ?IS_SET(S) -> + case unify_types([?TYPE(S)], T0) of + [] -> {error, type_mismatch}; + Type -> set_of_sets(Ss, [?LIST(S) | L], Type) + end; +set_of_sets([S | Ss], L, T0) when ?IS_ORDSET(S) -> + case unify_types(?ORDTYPE(S), T0) of + [] -> {error, type_mismatch}; + Type -> set_of_sets(Ss, [?ORDDATA(S) | L], Type) + end; +set_of_sets([], L, T) -> + ?SET(usort(L), T); +set_of_sets(_, _L, _T) -> + {error, badarg}. + +ordset_of_sets([S | Ss], L, T) when ?IS_SET(S) -> + ordset_of_sets(Ss, [?LIST(S) | L], [[?TYPE(S)] | T]); +ordset_of_sets([S | Ss], L, T) when ?IS_ORDSET(S) -> + ordset_of_sets(Ss, [?ORDDATA(S) | L], [?ORDTYPE(S) | T]); +ordset_of_sets([], L, T) -> + ?ORDSET(list_to_tuple(reverse(L)), list_to_tuple(reverse(T))); +ordset_of_sets(_, _L, _T) -> + error. + +%% Inlined. +rel(Ts, [Type]) -> + case is_type(Type) and atoms_only(Type, 1) of + true -> + rel(Ts, tuple_size(Type), Type); + false -> + rel_type(Ts, [], Type) + end; +rel(Ts, Sz) -> + rel(Ts, Sz, erlang:make_tuple(Sz, ?ATOM_TYPE)). + +atoms_only(Type, I) when ?IS_ATOM_TYPE(?REL_TYPE(I, Type)) -> + atoms_only(Type, I+1); +atoms_only(Type, I) when I > tuple_size(Type), ?IS_RELATION(Type) -> + true; +atoms_only(_Type, _I) -> + false. + +rel(Ts, Sz, Type) when Sz >= 1 -> + SL = usort(Ts), + rel(SL, SL, Sz, Type). + +rel([T | Ts], L, Sz, Type) when tuple_size(T) =:= Sz -> + rel(Ts, L, Sz, Type); +rel([], L, _Sz, Type) -> + ?SET(L, Type). + +rel_type([E | Ts], L, Type) -> + {NType, NE} = make_element(E, Type, Type), + rel_type(Ts, [NE | L], NType); +rel_type([], [], ?ANYTYPE) -> + empty_set(); +rel_type([], SL, Type) when ?IS_RELATION(Type) -> + ?SET(usort(SL), Type). + +%% Inlined. +a_func(Ts, T) -> + case {T, is_type(T)} of + {[?BINREL(DT, RT) = Type], true} when ?IS_ATOM_TYPE(DT), + ?IS_ATOM_TYPE(RT) -> + func(Ts, Type); + {[Type], true} -> + func_type(Ts, [], Type, fun(?BINREL(_,_)) -> true end) + end. + +func(L0, Type) -> + L = usort(L0), + func(L, L, L, Type). + +func([{X,_} | Ts], X0, L, Type) when X /= X0 -> + func(Ts, X, L, Type); +func([{X,_} | _Ts], X0, _L, _Type) when X == X0 -> + bad_function; +func([], _X0, L, Type) -> + ?SET(L, Type). + +%% Inlined. +fam(Ts, T) -> + case {T, is_type(T)} of + {[?FAMILY(DT, RT) = Type], true} when ?IS_ATOM_TYPE(DT), + ?IS_ATOM_TYPE(RT) -> + fam2(Ts, Type); + {[Type], true} -> + func_type(Ts, [], Type, fun(?FAMILY(_,_)) -> true end) + end. + +fam2([], Type) -> + ?SET([], Type); +fam2(Ts, Type) -> + fam2(sort(Ts), Ts, [], Type). + +fam2([{I,L} | T], I0, SL, Type) when I /= I0 -> + fam2(T, I, [{I,usort(L)} | SL], Type); +fam2([{I,L} | T], I0, SL, Type) when I == I0 -> + case {usort(L), SL} of + {NL, [{_I,NL1} | _]} when NL == NL1 -> + fam2(T, I0, SL, Type); + _ -> + bad_function + end; +fam2([], _I0, SL, Type) -> + ?SET(reverse(SL), Type). + +func_type([E | T], SL, Type, F) -> + {NType, NE} = make_element(E, Type, Type), + func_type(T, [NE | SL], NType, F); +func_type([], [], ?ANYTYPE, _F) -> + empty_set(); +func_type([], SL, Type, F) -> + true = F(Type), + NL = usort(SL), + check_function(NL, ?SET(NL, Type)). + +setify(L, ?SET_OF(Atom)) when ?IS_ATOM_TYPE(Atom), Atom =/= ?ANYTYPE -> + ?SET(usort(L), Atom); +setify(L, ?SET_OF(Type0)) -> + try is_no_lists(Type0) of + N when is_integer(N) -> + 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), + ?ORDSET(OrdSet, Type). + +is_no_lists(T) when is_tuple(T) -> + Sz = tuple_size(T), + is_no_lists(T, Sz, Sz, []). + +is_no_lists(_T, 0, Sz, []) -> + Sz; +is_no_lists(_T, 0, Sz, L) -> + {Sz, L}; +is_no_lists(T, I, Sz, L) when ?IS_ATOM_TYPE(?REL_TYPE(I, T)) -> + is_no_lists(T, I-1, Sz, L); +is_no_lists(T, I, Sz, L) -> + is_no_lists(T, I-1, Sz, [{I,is_no_lists(?REL_TYPE(I, T))} | L]). + +create([E | Es], T, T0, L) -> + {NT, S} = make_element(E, T, T0), + create(Es, NT, T0, [S | L]); +create([], T, _T0, L) -> + {?SET_OF(T), usort(L)}. + +make_element(C, ?ANYTYPE, _T0) -> + make_element(C); +make_element(C, Atom, ?ANYTYPE) when ?IS_ATOM_TYPE(Atom), + not is_list(C), not is_tuple(C) -> + {Atom, C}; +make_element(C, Atom, Atom) when ?IS_ATOM_TYPE(Atom) -> + {Atom, C}; +make_element(T, TT, ?ANYTYPE) when tuple_size(T) =:= tuple_size(TT) -> + make_tuple(tuple_to_list(T), tuple_to_list(TT), [], [], ?ANYTYPE); +make_element(T, TT, T0) when tuple_size(T) =:= tuple_size(TT) -> + make_tuple(tuple_to_list(T), tuple_to_list(TT), [], [], tuple_to_list(T0)); +make_element(L, [LT], ?ANYTYPE) when is_list(L) -> + create(L, LT, ?ANYTYPE, []); +make_element(L, [LT], [T0]) when is_list(L) -> + create(L, LT, T0, []). + +make_tuple([E | Es], [T | Ts], NT, L, T0) when T0 =:= ?ANYTYPE -> + {ET, ES} = make_element(E, T, T0), + make_tuple(Es, Ts, [ET | NT], [ES | L], T0); +make_tuple([E | Es], [T | Ts], NT, L, [T0 | T0s]) -> + {ET, ES} = make_element(E, T, T0), + make_tuple(Es, Ts, [ET | NT], [ES | L], T0s); +make_tuple([], [], NT, L, _T0s) when NT =/= [] -> + {list_to_tuple(reverse(NT)), list_to_tuple(reverse(L))}. + +%% Derive type. +make_element(C) when not is_list(C), not is_tuple(C) -> + {?ATOM_TYPE, C}; +make_element(T) when is_tuple(T) -> + make_tuple(tuple_to_list(T), [], []); +make_element(L) when is_list(L) -> + create(L, ?ANYTYPE, ?ANYTYPE, []). + +make_tuple([E | Es], T, L) -> + {ET, ES} = make_element(E), + make_tuple(Es, [ET | T], [ES | L]); +make_tuple([], T, L) when T =/= [] -> + {list_to_tuple(reverse(T)), list_to_tuple(reverse(L))}. + +make_oset([T | Ts], Szs, L, Type) -> + true = test_oset(Szs, T, T), + make_oset(Ts, Szs, L, Type); +make_oset([], _Szs, L, Type) -> + ?SET(usort(L), Type). + +%% Optimization. Avoid re-building (nested) tuples. +test_oset({Sz,Args}, T, T0) when tuple_size(T) =:= Sz -> + test_oset_args(Args, T, T0); +test_oset(Sz, T, _T0) when tuple_size(T) =:= Sz -> + true. + +test_oset_args([{Arg,Szs} | Ss], T, T0) -> + true = test_oset(Szs, ?REL_TYPE(Arg, T), T0), + test_oset_args(Ss, T, T0); +test_oset_args([], _T, _T0) -> + true. + +list_of_sets([S | Ss], Type, L) -> + list_of_sets(Ss, Type, [?SET(S, Type) | L]); +list_of_sets([], _Type, L) -> + reverse(L). + +list_of_ordsets([S | Ss], Type, L) -> + list_of_ordsets(Ss, Type, [?ORDSET(S, Type) | L]); +list_of_ordsets([], _Type, L) -> + reverse(L). + +tuple_of_sets([S | Ss], [?SET_OF(Type) | Types], L) -> + tuple_of_sets(Ss, Types, [?SET(S, Type) | L]); +tuple_of_sets([S | Ss], [Type | Types], L) -> + tuple_of_sets(Ss, Types, [?ORDSET(S, Type) | L]); +tuple_of_sets([], [], L) -> + list_to_tuple(reverse(L)). + +spec([E | Es], Fun, Type, L) -> + case Fun(term2set(E, Type)) of + true -> + spec(Es, Fun, Type, [E | L]); + false -> + spec(Es, Fun, Type, L); + _ -> + badarg + end; +spec([], _Fun, _Type, L) -> + reverse(L). + +specification([E | Es], Fun, L) -> + case Fun(E) of + true -> + specification(Es, Fun, [E | L]); + false -> + specification(Es, Fun, L); + _ -> + badarg + end; +specification([], _Fun, L) -> + reverse(L). + +%% Elements from the first list are kept. +intersection([H1 | T1], [H2 | T2], L) when H1 < H2 -> + intersection1(T1, T2, L, H2); +intersection([H1 | T1], [H2 | T2], L) when H1 == H2 -> + intersection(T1, T2, [H1 | L]); +intersection([H1 | T1], [_H2 | T2], L) -> + intersection2(T1, T2, L, H1); +intersection(_, _, L) -> + reverse(L). + +intersection1([H1 | T1], T2, L, H2) when H1 < H2 -> + intersection1(T1, T2, L, H2); +intersection1([H1 | T1], T2, L, H2) when H1 == H2 -> + intersection(T1, T2, [H1 | L]); +intersection1([H1 | T1], T2, L, _H2) -> + intersection2(T1, T2, L, H1); +intersection1(_, _, L, _) -> + reverse(L). + +intersection2(T1, [H2 | T2], L, H1) when H1 > H2 -> + intersection2(T1, T2, L, H1); +intersection2(T1, [H2 | T2], L, H1) when H1 == H2 -> + intersection(T1, T2, [H1 | L]); +intersection2(T1, [H2 | T2], L, _H1) -> + intersection1(T1, T2, L, H2); +intersection2(_, _, L, _) -> + reverse(L). + +difference([H1 | T1], [H2 | T2], L) when H1 < H2 -> + diff(T1, T2, [H1 | L], H2); +difference([H1 | T1], [H2 | T2], L) when H1 == H2 -> + difference(T1, T2, L); +difference([H1 | T1], [_H2 | T2], L) -> + diff2(T1, T2, L, H1); +difference(L1, _, L) -> + reverse(L, L1). + +diff([H1 | T1], T2, L, H2) when H1 < H2 -> + diff(T1, T2, [H1 | L], H2); +diff([H1 | T1], T2, L, H2) when H1 == H2 -> + difference(T1, T2, L); +diff([H1 | T1], T2, L, _H2) -> + diff2(T1, T2, L, H1); +diff(_, _, L, _) -> + reverse(L). + +diff2(T1, [H2 | T2], L, H1) when H1 > H2 -> + diff2(T1, T2, L, H1); +diff2(T1, [H2 | T2], L, H1) when H1 == H2 -> + difference(T1, T2, L); +diff2(T1, [H2 | T2], L, H1) -> + diff(T1, T2, [H1 | L], H2); +diff2(T1, _, L, H1) -> + reverse(L, [H1 | T1]). + +symdiff([H1 | T1], T2, L) -> + symdiff2(T1, T2, L, H1); +symdiff(_, T2, L) -> + reverse(L, T2). + +symdiff1([H1 | T1], T2, L, H2) when H1 < H2 -> + symdiff1(T1, T2, [H1 | L], H2); +symdiff1([H1 | T1], T2, L, H2) when H1 == H2 -> + symdiff(T1, T2, L); +symdiff1([H1 | T1], T2, L, H2) -> + symdiff2(T1, T2, [H2 | L], H1); +symdiff1(_, T2, L, H2) -> + reverse(L, [H2 | T2]). + +symdiff2(T1, [H2 | T2], L, H1) when H1 > H2 -> + symdiff2(T1, T2, [H2 | L], H1); +symdiff2(T1, [H2 | T2], L, H1) when H1 == H2 -> + symdiff(T1, T2, L); +symdiff2(T1, [H2 | T2], L, H1) -> + symdiff1(T1, T2, [H1 | L], H2); +symdiff2(T1, _, L, H1) -> + reverse(L, [H1 | T1]). + +sympart([H1 | T1], [H2 | T2], L1, L12, L2, T) when H1 < H2 -> + sympart1(T1, T2, [H1 | L1], L12, L2, T, H2); +sympart([H1 | T1], [H2 | T2], L1, L12, L2, T) when H1 == H2 -> + sympart(T1, T2, L1, [H1 | L12], L2, T); +sympart([H1 | T1], [H2 | T2], L1, L12, L2, T) -> + sympart2(T1, T2, L1, L12, [H2 | L2], T, H1); +sympart(S1, [], L1, L12, L2, T) -> + {?SET(reverse(L1, S1), T), + ?SET(reverse(L12), T), + ?SET(reverse(L2), T)}; +sympart(_, S2, L1, L12, L2, T) -> + {?SET(reverse(L1), T), + ?SET(reverse(L12), T), + ?SET(reverse(L2, S2), T)}. + +sympart1([H1 | T1], T2, L1, L12, L2, T, H2) when H1 < H2 -> + sympart1(T1, T2, [H1 | L1], L12, L2, T, H2); +sympart1([H1 | T1], T2, L1, L12, L2, T, H2) when H1 == H2 -> + sympart(T1, T2, L1, [H1 | L12], L2, T); +sympart1([H1 | T1], T2, L1, L12, L2, T, H2) -> + sympart2(T1, T2, L1, L12, [H2 | L2], T, H1); +sympart1(_, T2, L1, L12, L2, T, H2) -> + {?SET(reverse(L1), T), + ?SET(reverse(L12), T), + ?SET(reverse(L2, [H2 | T2]), T)}. + +sympart2(T1, [H2 | T2], L1, L12, L2, T, H1) when H1 > H2 -> + sympart2(T1, T2, L1, L12, [H2 | L2], T, H1); +sympart2(T1, [H2 | T2], L1, L12, L2, T, H1) when H1 == H2 -> + sympart(T1, T2, L1, [H1 | L12], L2, T); +sympart2(T1, [H2 | T2], L1, L12, L2, T, H1) -> + sympart1(T1, T2, [H1 | L1], L12, L2, T, H2); +sympart2(T1, _, L1, L12, L2, T, H1) -> + {?SET(reverse(L1, [H1 | T1]), T), + ?SET(reverse(L12), T), + ?SET(reverse(L2), T)}. + +prod([[E | Es] | Xs], T, L) -> + prod(Es, Xs, T, prod(Xs, [E | T], L)); +prod([], T, L) -> + [list_to_tuple(reverse(T)) | L]. + +prod([E | Es], Xs, T, L) -> + prod(Es, Xs, T, prod(Xs, [E | T], L)); +prod([], _Xs, _E, L) -> + L. + +constant_function([E | Es], X, L) -> + constant_function(Es, X, [{E,X} | L]); +constant_function([], _X, L) -> + reverse(L). + +subset([H1 | T1], [H2 | T2]) when H1 > H2 -> + subset(T1, T2, H1); +subset([H1 | T1], [H2 | T2]) when H1 == H2 -> + subset(T1, T2); +subset(L1, _) -> + L1 =:= []. + +subset(T1, [H2 | T2], H1) when H1 > H2 -> + subset(T1, T2, H1); +subset(T1, [H2 | T2], H1) when H1 == H2 -> + subset(T1, T2); +subset(_, _, _) -> + false. + +disjoint([B | Bs], A, As) when A < B -> + disjoint(As, B, Bs); +disjoint([B | _Bs], A, _As) when A == B -> + false; +disjoint([_B | Bs], A, As) -> + disjoint(Bs, A, As); +disjoint(_Bs, _A, _As) -> + true. + +%% Append sets that come in order, then "merge". +lunion([[_] = S]) -> % optimization + S; +lunion([[] | Ls]) -> + lunion(Ls); +lunion([S | Ss]) -> + umerge(lunion(Ss, last(S), [S], [])); +lunion([]) -> + []. + +lunion([[E] = S | Ss], Last, SL, Ls) when E > Last -> % optimization + lunion(Ss, E, [S | SL], Ls); +lunion([S | Ss], Last, SL, Ls) when hd(S) > Last -> + lunion(Ss, last(S), [S | SL], Ls); +lunion([S | Ss], _Last, SL, Ls) -> + lunion(Ss, last(S), [S], [append(reverse(SL)) | Ls]); +lunion([], _Last, SL, Ls) -> + [append(reverse(SL)) | Ls]. + +%% The empty list is always the first list, if present. +lintersection(_, []) -> + []; +lintersection([S | Ss], S0) -> + lintersection(Ss, intersection(S, S0, [])); +lintersection([], S) -> + S. + +can_rel([S | Ss], L) -> + can_rel(Ss, L, S, S); +can_rel([], L) -> + sort(L). + +can_rel(Ss, L, [E | Es], S) -> + can_rel(Ss, [{E, S} | L], Es, S); +can_rel(Ss, L, _, _S) -> + can_rel(Ss, L). + +rel2family([{X,Y} | S]) -> + rel2fam(S, X, [Y], []); +rel2family([]) -> + []. + +rel2fam([{X,Y} | S], X0, YL, L) when X0 == X -> + rel2fam(S, X0, [Y | YL], L); +rel2fam([{X,Y} | S], X0, [A,B | YL], L) -> % optimization + rel2fam(S, X, [Y], [{X0,reverse(YL,[B,A])} | L]); +rel2fam([{X,Y} | S], X0, YL, L) -> + rel2fam(S, X, [Y], [{X0,YL} | L]); +rel2fam([], X, YL, L) -> + reverse([{X,reverse(YL)} | L]). + +dom([{X,_} | Es]) -> + dom([], X, Es); +dom([] = L) -> + L. + +dom(L, X, [{X1,_} | Es]) when X == X1 -> + dom(L, X, Es); +dom(L, X, [{Y,_} | Es]) -> + dom([X | L], Y, Es); +dom(L, X, []) -> + reverse(L, [X]). + +ran([{_,Y} | Es], L) -> + ran(Es, [Y | L]); +ran([], L) -> + usort(L). + +relprod(A, B) -> + usort(relprod1(A, B)). + +relprod1([{Ay,Ax} | A], B) -> + relprod1(B, Ay, Ax, A, []); +relprod1(_A, _B) -> + []. + +relprod1([{Bx,_By} | B], Ay, Ax, A, L) when Ay > Bx -> + relprod1(B, Ay, Ax, A, L); +relprod1([{Bx,By} | B], Ay, Ax, A, L) when Ay == Bx -> + relprod(B, Bx, By, A, [{Ax,By} | L], Ax, B, Ay); +relprod1([{Bx,By} | B], _Ay, _Ax, A, L) -> + relprod2(B, Bx, By, A, L); +relprod1(_B, _Ay, _Ax, _A, L) -> + L. + +relprod2(B, Bx, By, [{Ay, _Ax} | A], L) when Ay < Bx -> + relprod2(B, Bx, By, A, L); +relprod2(B, Bx, By, [{Ay, Ax} | A], L) when Ay == Bx -> + relprod(B, Bx, By, A, [{Ax,By} | L], Ax, B, Ay); +relprod2(B, _Bx, _By, [{Ay, Ax} | A], L) -> + relprod1(B, Ay, Ax, A, L); +relprod2(_, _, _, _, L) -> + L. + +relprod(B0, Bx0, By0, A0, L, Ax, [{Bx,By} | B], Ay) when Ay == Bx -> + relprod(B0, Bx0, By0, A0, [{Ax,By} | L], Ax, B, Ay); +relprod(B0, Bx0, By0, A0, L, _Ax, _B, _Ay) -> + relprod2(B0, Bx0, By0, A0, L). + +relprod_n([], _R, _EmptyG, _IsR) -> + {error, badarg}; +relprod_n(RL, R, EmptyR, IsR) -> + case domain_type(RL, ?ANYTYPE) of + Error = {error, _Reason} -> + Error; + DType -> + Empty = any(fun is_empty_set/1, RL) or EmptyR, + RType = range_type(RL, []), + Type = ?BINREL(DType, RType), + Prod = + case Empty of + true when DType =:= ?ANYTYPE; RType =:= ?ANYTYPE -> + empty_set(); + true -> + ?SET([], Type); + false -> + TL = ?LIST((relprod_n(RL))), + Sz = length(RL), + Fun = fun({X,A}) -> {X, flat(Sz, A, [])} end, + ?SET(map(Fun, TL), Type) + end, + case IsR of + true -> relative_product(Prod, R); + false -> Prod + end + end. + +relprod_n([R | Rs]) -> + relprod_n(Rs, R). + +relprod_n([], R) -> + R; +relprod_n([R | Rs], R0) -> + T = raise_element(R0, 1), + R1 = relative_product1(T, R), + NR = projection({external, fun({{X,A},AS}) -> {X,{A,AS}} end}, R1), + relprod_n(Rs, NR). + +flat(1, A, L) -> + list_to_tuple([A | L]); +flat(N, {T,A}, L) -> + flat(N-1, T, [A | L]). + +domain_type([T | Ts], T0) when ?IS_SET(T) -> + case ?TYPE(T) of + ?BINREL(DT, _RT) -> + case unify_types(DT, T0) of + [] -> {error, type_mismatch}; + T1 -> domain_type(Ts, T1) + end; + ?ANYTYPE -> + domain_type(Ts, T0); + _ -> {error, badarg} + end; +domain_type([], T0) -> + T0. + +range_type([T | Ts], L) -> + case ?TYPE(T) of + ?BINREL(_DT, RT) -> + range_type(Ts, [RT | L]); + ?ANYTYPE -> + ?ANYTYPE + end; +range_type([], L) -> + list_to_tuple(reverse(L)). + +converse([{A,B} | X], L) -> + converse(X, [{B,A} | L]); +converse([], L) -> + sort(L). + +strict([{E1,E2} | Es], L) when E1 == E2 -> + strict(Es, L); +strict([E | Es], L) -> + strict(Es, [E | L]); +strict([], L) -> + reverse(L). + +weak(Es) -> + %% Not very efficient... + weak(Es, ran(Es, []), []). + +weak(Es=[{X,_} | _], [Y | Ys], L) when X > Y -> + weak(Es, Ys, [{Y,Y} | L]); +weak(Es=[{X,_} | _], [Y | Ys], L) when X == Y -> + weak(Es, Ys, L); +weak([E={X,Y} | Es], Ys, L) when X > Y -> + weak1(Es, Ys, [E | L], X); +weak([E={X,Y} | Es], Ys, L) when X == Y -> + weak2(Es, Ys, [E | L], X); +weak([E={X,_Y} | Es], Ys, L) -> % when X < _Y + weak2(Es, Ys, [E, {X,X} | L], X); +weak([], [Y | Ys], L) -> + weak([], Ys, [{Y,Y} | L]); +weak([], [], L) -> + reverse(L). + +weak1([E={X,Y} | Es], Ys, L, X0) when X > Y, X == X0 -> + weak1(Es, Ys, [E | L], X); +weak1([E={X,Y} | Es], Ys, L, X0) when X == Y, X == X0 -> + weak2(Es, Ys, [E | L], X); +weak1([E={X,_Y} | Es], Ys, L, X0) when X == X0 -> % when X < Y + weak2(Es, Ys, [E, {X,X} | L], X); +weak1(Es, Ys, L, X) -> + weak(Es, Ys, [{X,X} | L]). + +weak2([E={X,_Y} | Es], Ys, L, X0) when X == X0 -> % when X < _Y + weak2(Es, Ys, [E | L], X); +weak2(Es, Ys, L, _X) -> + weak(Es, Ys, L). + +extc(L, [D | Ds], C, Ts) -> + extc(L, Ds, C, Ts, D); +extc(L, [], _C, _Ts) -> + L. + +extc(L, Ds, C, [{X,_Y} | Ts], D) when X < D -> + extc(L, Ds, C, Ts, D); +extc(L, Ds, C, [{X,_Y} | Ts], D) when X == D -> + extc(L, Ds, C, Ts); +extc(L, Ds, C, [{X,_Y} | Ts], D) -> + extc2([{D,C} | L], Ds, C, Ts, X); +extc(L, Ds, C, [], D) -> + extc_tail([{D,C} | L], Ds, C). + +extc2(L, [D | Ds], C, Ts, X) when X > D -> + extc2([{D,C} | L], Ds, C, Ts, X); +extc2(L, [D | Ds], C, Ts, X) when X == D -> + extc(L, Ds, C, Ts); +extc2(L, [D | Ds], C, Ts, _X) -> + extc(L, Ds, C, Ts, D); +extc2(L, [], _C, _Ts, _X) -> + L. + +extc_tail(L, [D | Ds], C) -> + extc_tail([{D,C} | L], Ds, C); +extc_tail(L, [], _C) -> + L. + +is_a_func([{E,_} | Es], E0) when E /= E0 -> + is_a_func(Es, E); +is_a_func(L, _E) -> + L =:= []. + +restrict_n(I, [T | Ts], Key, Keys, L) -> + case element(I, T) of + K when K < Key -> + restrict_n(I, Ts, Key, Keys, L); + K when K == Key -> + restrict_n(I, Ts, Key, Keys, [T | L]); + K -> + restrict_n(I, K, Ts, Keys, L, T) + end; +restrict_n(_I, _Ts, _Key, _Keys, L) -> + L. + +restrict_n(I, K, Ts, [Key | Keys], L, E) when K > Key -> + restrict_n(I, K, Ts, Keys, L, E); +restrict_n(I, K, Ts, [Key | Keys], L, E) when K == Key -> + restrict_n(I, Ts, Key, Keys, [E | L]); +restrict_n(I, _K, Ts, [Key | Keys], L, _E) -> + restrict_n(I, Ts, Key, Keys, L); +restrict_n(_I, _K, _Ts, _Keys, L, _E) -> + L. + +restrict([Key | Keys], Tuples) -> + restrict(Tuples, Key, Keys, []); +restrict(_Keys, _Tuples) -> + []. + +restrict([{K,_E} | Ts], Key, Keys, L) when K < Key -> + restrict(Ts, Key, Keys, L); +restrict([{K,E} | Ts], Key, Keys, L) when K == Key -> + restrict(Ts, Key, Keys, [E | L]); +restrict([{K,E} | Ts], _Key, Keys, L) -> + restrict(Ts, K, Keys, L, E); +restrict(_Ts, _Key, _Keys, L) -> + L. + +restrict(Ts, K, [Key | Keys], L, E) when K > Key -> + restrict(Ts, K, Keys, L, E); +restrict(Ts, K, [Key | Keys], L, E) when K == Key -> + restrict(Ts, Key, Keys, [E | L]); +restrict(Ts, _K, [Key | Keys], L, _E) -> + restrict(Ts, Key, Keys, L); +restrict(_Ts, _K, _Keys, L, _E) -> + L. + +diff_restrict_n(I, [T | Ts], Key, Keys, L) -> + case element(I, T) of + K when K < Key -> + diff_restrict_n(I, Ts, Key, Keys, [T | L]); + K when K == Key -> + diff_restrict_n(I, Ts, Key, Keys, L); + K -> + diff_restrict_n(I, K, Ts, Keys, L, T) + end; +diff_restrict_n(I, _Ts, _Key, _Keys, L) when I =:= 1 -> + reverse(L); +diff_restrict_n(_I, _Ts, _Key, _Keys, L) -> + sort(L). + +diff_restrict_n(I, K, Ts, [Key | Keys], L, T) when K > Key -> + diff_restrict_n(I, K, Ts, Keys, L, T); +diff_restrict_n(I, K, Ts, [Key | Keys], L, _T) when K == Key -> + diff_restrict_n(I, Ts, Key, Keys, L); +diff_restrict_n(I, _K, Ts, [Key | Keys], L, T) -> + diff_restrict_n(I, Ts, Key, Keys, [T | L]); +diff_restrict_n(I, _K, Ts, _Keys, L, T) when I =:= 1 -> + reverse(L, [T | Ts]); +diff_restrict_n(_I, _K, Ts, _Keys, L, T) -> + sort([T | Ts ++ L]). + +diff_restrict([Key | Keys], Tuples) -> + diff_restrict(Tuples, Key, Keys, []); +diff_restrict(_Keys, Tuples) -> + diff_restrict_tail(Tuples, []). + +diff_restrict([{K,E} | Ts], Key, Keys, L) when K < Key -> + diff_restrict(Ts, Key, Keys, [E | L]); +diff_restrict([{K,_E} | Ts], Key, Keys, L) when K == Key -> + diff_restrict(Ts, Key, Keys, L); +diff_restrict([{K,E} | Ts], _Key, Keys, L) -> + diff_restrict(Ts, K, Keys, L, E); +diff_restrict(_Ts, _Key, _Keys, L) -> + L. + +diff_restrict(Ts, K, [Key | Keys], L, E) when K > Key -> + diff_restrict(Ts, K, Keys, L, E); +diff_restrict(Ts, K, [Key | Keys], L, _E) when K == Key -> + diff_restrict(Ts, Key, Keys, L); +diff_restrict(Ts, _K, [Key | Keys], L, E) -> + diff_restrict(Ts, Key, Keys, [E | L]); +diff_restrict(Ts, _K, _Keys, L, E) -> + diff_restrict_tail(Ts, [E | L]). + +diff_restrict_tail([{_K,E} | Ts], L) -> + diff_restrict_tail(Ts, [E | L]); +diff_restrict_tail(_Ts, L) -> + L. + +comp([], B) -> + check_function(B, []); +comp(_A, []) -> + bad_function; +comp(A0, [{Bx,By} | B]) -> + A = converse(A0, []), + check_function(A0, comp1(A, B, [], Bx, By)). + +comp1([{Ay,Ax} | A], B, L, Bx, By) when Ay == Bx -> + comp1(A, B, [{Ax,By} | L], Bx, By); +comp1([{Ay,Ax} | A], B, L, Bx, _By) when Ay > Bx -> + comp2(A, B, L, Bx, Ay, Ax); +comp1([{Ay,_Ax} | _A], _B, _L, Bx, _By) when Ay < Bx -> + bad_function; +comp1([], B, L, Bx, _By) -> + check_function(Bx, B, L). + +comp2(A, [{Bx,_By} | B], L, Bx0, Ay, Ax) when Ay > Bx, Bx /= Bx0 -> + comp2(A, B, L, Bx, Ay, Ax); +comp2(A, [{Bx,By} | B], L, _Bx0, Ay, Ax) when Ay == Bx -> + comp1(A, B, [{Ax,By} | L], Bx, By); +comp2(_A, _B, _L, _Bx0, _Ay, _Ax) -> + bad_function. + +inverse1([{A,B} | X]) -> + inverse(X, A, [{B,A}]); +inverse1([]) -> + []. + +inverse([{A,B} | X], A0, L) when A0 /= A -> + inverse(X, A, [{B,A} | L]); +inverse([{A,_B} | _X], A0, _L) when A0 == A -> + bad_function; +inverse([], _A0, L) -> + SL = [{V,_} | Es] = sort(L), + case is_a_func(Es, V) of + true -> SL; + false -> bad_function + end. + +%% Inlined. +external_fun({external, Function}) when is_atom(Function) -> + false; +external_fun({external, Fun}) -> + Fun; +external_fun(_) -> + false. + +%% Inlined. +element_type(?SET_OF(Type)) -> Type; +element_type(Type) -> Type. + +subst(Ts, Fun, Type) -> + subst(Ts, Fun, Type, ?ANYTYPE, []). + +subst([T | Ts], Fun, Type, NType, L) -> + case setfun(T, Fun, Type, NType) of + {SD, ST} -> subst(Ts, Fun, Type, ST, [{T, SD} | L]); + Bad -> Bad + end; +subst([], _Fun, _Type, NType, L) -> + {L, NType}. + +projection1([E | Es]) -> + projection1([], element(1, E), Es); +projection1([] = L) -> + L. + +projection1(L, X, [E | Es]) -> + case element(1, E) of + X1 when X == X1 -> projection1(L, X, Es); + X1 -> projection1([X | L], X1, Es) + end; +projection1(L, X, []) -> + reverse(L, [X]). + +projection_n([E | Es], I, L) -> + projection_n(Es, I, [element(I, E) | L]); +projection_n([], _I, L) -> + usort(L). + +substitute_element([T | Ts], I, L) -> + substitute_element(Ts, I, [{T, element(I, T)} | L]); +substitute_element(_, _I, L) -> + reverse(L). + +substitute([T | Ts], Fun, L) -> + substitute(Ts, Fun, [{T, Fun(T)} | L]); +substitute(_, _Fun, L) -> + reverse(L). + +partition_n(I, [E | Ts]) -> + partition_n(I, Ts, element(I, E), [E], []); +partition_n(_I, []) -> + []. + +partition_n(I, [E | Ts], K, Es, P) -> + case {element(I, E), Es} of + {K1, _} when K == K1 -> + partition_n(I, Ts, K, [E | Es], P); + {K1, [_]} -> % optimization + partition_n(I, Ts, K1, [E], [Es | P]); + {K1, _} -> + partition_n(I, Ts, K1, [E], [reverse(Es) | P]) + end; +partition_n(I, [], _K, Es, P) when I > 1 -> + sort([reverse(Es) | P]); +partition_n(_I, [], _K, [_] = Es, P) -> % optimization + reverse(P, [Es]); +partition_n(_I, [], _K, Es, P) -> + reverse(P, [reverse(Es)]). + +partition3_n(I, [T | Ts], Key, Keys, L1, L2) -> + case element(I, T) of + K when K < Key -> + partition3_n(I, Ts, Key, Keys, L1, [T | L2]); + K when K == Key -> + partition3_n(I, Ts, Key, Keys, [T | L1], L2); + K -> + partition3_n(I, K, Ts, Keys, L1, L2, T) + end; +partition3_n(I, _Ts, _Key, _Keys, L1, L2) when I =:= 1 -> + [reverse(L1) | reverse(L2)]; +partition3_n(_I, _Ts, _Key, _Keys, L1, L2) -> + [sort(L1) | sort(L2)]. + +partition3_n(I, K, Ts, [Key | Keys], L1, L2, T) when K > Key -> + partition3_n(I, K, Ts, Keys, L1, L2, T); +partition3_n(I, K, Ts, [Key | Keys], L1, L2, T) when K == Key -> + partition3_n(I, Ts, Key, Keys, [T | L1], L2); +partition3_n(I, _K, Ts, [Key | Keys], L1, L2, T) -> + partition3_n(I, Ts, Key, Keys, L1, [T | L2]); +partition3_n(I, _K, Ts, _Keys, L1, L2, T) when I =:= 1 -> + [reverse(L1) | reverse(L2, [T | Ts])]; +partition3_n(_I, _K, Ts, _Keys, L1, L2, T) -> + [sort(L1) | sort([T | Ts ++ L2])]. + +partition3([Key | Keys], Tuples) -> + partition3(Tuples, Key, Keys, [], []); +partition3(_Keys, Tuples) -> + partition3_tail(Tuples, [], []). + +partition3([{K,E} | Ts], Key, Keys, L1, L2) when K < Key -> + partition3(Ts, Key, Keys, L1, [E | L2]); +partition3([{K,E} | Ts], Key, Keys, L1, L2) when K == Key -> + partition3(Ts, Key, Keys, [E | L1], L2); +partition3([{K,E} | Ts], _Key, Keys, L1, L2) -> + partition3(Ts, K, Keys, L1, L2, E); +partition3(_Ts, _Key, _Keys, L1, L2) -> + [L1 | L2]. + +partition3(Ts, K, [Key | Keys], L1, L2, E) when K > Key -> + partition3(Ts, K, Keys, L1, L2, E); +partition3(Ts, K, [Key | Keys], L1, L2, E) when K == Key -> + partition3(Ts, Key, Keys, [E | L1], L2); +partition3(Ts, _K, [Key | Keys], L1, L2, E) -> + partition3(Ts, Key, Keys, L1, [E | L2]); +partition3(Ts, _K, _Keys, L1, L2, E) -> + partition3_tail(Ts, L1, [E | L2]). + +partition3_tail([{_K,E} | Ts], L1, L2) -> + partition3_tail(Ts, L1, [E | L2]); +partition3_tail(_Ts, L1, L2) -> + [L1 | L2]. + +replace([E | Es], F, L) -> + replace(Es, F, [F(E) | L]); +replace(_, _F, L) -> + sort(L). + +mul_relprod([T | Ts], I, R) when ?IS_SET(T) -> + P = raise_element(R, I), + F = relative_product1(P, T), + [F | mul_relprod(Ts, I+1, R)]; +mul_relprod([], _I, _R) -> + []. + +raise_element(R, I) -> + L = sort(I =/= 1, rearr(?LIST(R), I, [])), + Type = ?TYPE(R), + ?SET(L, ?BINREL(?REL_TYPE(I, Type), Type)). + +rearr([E | Es], I, L) -> + rearr(Es, I, [{element(I, E), E} | L]); +rearr([], _I, L) -> + L. + +join_element(E1, E2) -> + [_ | L2] = tuple_to_list(E2), + list_to_tuple(tuple_to_list(E1) ++ L2). + +join_element(E1, E2, I2) -> + tuple_to_list(E1) ++ join_element2(tuple_to_list(E2), 1, I2). + +join_element2([B | Bs], C, I2) when C =/= I2 -> + [B | join_element2(Bs, C+1, I2)]; +join_element2([_ | Bs], _C, _I2) -> + Bs. + +family2rel([{X,S} | F], L) -> + fam2rel(F, L, X, S); +family2rel([], L) -> + reverse(L). + +fam2rel(F, L, X, [Y | Ys]) -> + fam2rel(F, [{X,Y} | L], X, Ys); +fam2rel(F, L, _X, _) -> + family2rel(F, L). + +fam_spec([{_,S}=E | F], Fun, Type, L) -> + case Fun(?SET(S, Type)) of + true -> + fam_spec(F, Fun, Type, [E | L]); + false -> + fam_spec(F, Fun, Type, L); + _ -> + badarg + end; +fam_spec([], _Fun, _Type, L) -> + reverse(L). + +fam_specification([{_,S}=E | F], Fun, L) -> + case Fun(S) of + true -> + fam_specification(F, Fun, [E | L]); + false -> + fam_specification(F, Fun, L); + _ -> + badarg + end; +fam_specification([], _Fun, L) -> + reverse(L). + +un_of_fam([{_X,S} | F], L) -> + un_of_fam(F, [S | L]); +un_of_fam([], L) -> + lunion(sort(L)). + +int_of_fam([{_,S} | F]) -> + int_of_fam(F, [S]); +int_of_fam([]) -> + badarg. + +int_of_fam([{_,S} | F], L) -> + int_of_fam(F, [S | L]); +int_of_fam([], [L | Ls]) -> + lintersection(Ls, L). + +fam_un([{X,S} | F], L) -> + fam_un(F, [{X, lunion(S)} | L]); +fam_un([], L) -> + reverse(L). + +fam_int([{X, [S | Ss]} | F], L) -> + fam_int(F, [{X, lintersection(Ss, S)} | L]); +fam_int([{_X,[]} | _F], _L) -> + badarg; +fam_int([], L) -> + reverse(L). + +fam_dom([{X,S} | F], L) -> + fam_dom(F, [{X, dom(S)} | L]); +fam_dom([], L) -> + reverse(L). + +fam_ran([{X,S} | F], L) -> + fam_ran(F, [{X, ran(S, [])} | L]); +fam_ran([], L) -> + reverse(L). + +fam_union(F1 = [{A,_AS} | _AL], [B1={B,_BS} | BL], L) when A > B -> + fam_union(F1, BL, [B1 | L]); +fam_union([{A,AS} | AL], [{B,BS} | BL], L) when A == B -> + fam_union(AL, BL, [{A, umerge(AS, BS)} | L]); +fam_union([A1 | AL], F2, L) -> + fam_union(AL, F2, [A1 | L]); +fam_union(_, F2, L) -> + reverse(L, F2). + +fam_intersect(F1 = [{A,_AS} | _AL], [{B,_BS} | BL], L) when A > B -> + fam_intersect(F1, BL, L); +fam_intersect([{A,AS} | AL], [{B,BS} | BL], L) when A == B -> + fam_intersect(AL, BL, [{A, intersection(AS, BS, [])} | L]); +fam_intersect([_A1 | AL], F2, L) -> + fam_intersect(AL, F2, L); +fam_intersect(_, _, L) -> + reverse(L). + +fam_difference(F1 = [{A,_AS} | _AL], [{B,_BS} | BL], L) when A > B -> + fam_difference(F1, BL, L); +fam_difference([{A,AS} | AL], [{B,BS} | BL], L) when A == B -> + fam_difference(AL, BL, [{A, difference(AS, BS, [])} | L]); +fam_difference([A1 | AL], F2, L) -> + fam_difference(AL, F2, [A1 | L]); +fam_difference(F1, _, L) -> + reverse(L, F1). + +check_function([{X,_} | XL], R) -> + check_function(X, XL, R); +check_function([], R) -> + R. + +check_function(X0, [{X,_} | XL], R) when X0 /= X -> + check_function(X, XL, R); +check_function(X0, [{X,_} | _XL], _R) when X0 == X -> + bad_function; +check_function(_X0, [], R) -> + R. + +fam_partition_n(I, [E | Ts]) -> + fam_partition_n(I, Ts, element(I, E), [E], []); +fam_partition_n(_I, []) -> + []. + +fam_partition_n(I, [E | Ts], K, Es, P) -> + case {element(I, E), Es} of + {K1, _} when K == K1 -> + fam_partition_n(I, Ts, K, [E | Es], P); + {K1, [_]} -> % optimization + fam_partition_n(I, Ts, K1, [E], [{K,Es} | P]); + {K1, _} -> + fam_partition_n(I, Ts, K1, [E], [{K,reverse(Es)} | P]) + end; +fam_partition_n(_I, [], K, [_] = Es, P) -> % optimization + reverse(P, [{K,Es}]); +fam_partition_n(_I, [], K, Es, P) -> + reverse(P, [{K,reverse(Es)}]). + +fam_partition([{K,Vs} | Ts], Sort) -> + fam_partition(Ts, K, [Vs], [], Sort); +fam_partition([], _Sort) -> + []. + +fam_partition([{K1,V} | Ts], K, Vs, P, S) when K1 == K -> + fam_partition(Ts, K, [V | Vs], P, S); +fam_partition([{K1,V} | Ts], K, [_] = Vs, P, S) -> % optimization + fam_partition(Ts, K1, [V], [{K, Vs} | P], S); +fam_partition([{K1,V} | Ts], K, Vs, P, S) -> + fam_partition(Ts, K1, [V], [{K, sort(S, Vs)} | P], S); +fam_partition([], K, [_] = Vs, P, _S) -> % optimization + [{K, Vs} | P]; +fam_partition([], K, Vs, P, S) -> + [{K, sort(S, Vs)} | P]. + +fam_proj([{X,S} | F], Fun, Type, NType, L) -> + case setfun(S, Fun, Type, NType) of + {SD, ST} -> fam_proj(F, Fun, Type, ST, [{X, SD} | L]); + Bad -> Bad + end; +fam_proj([], _Fun, _Type, NType, L) -> + {reverse(L), NType}. + +setfun(T, Fun, Type, NType) -> + case Fun(term2set(T, Type)) of + NS when ?IS_SET(NS) -> + case unify_types(NType, ?SET_OF(?TYPE(NS))) of + [] -> type_mismatch; + NT -> {?LIST(NS), NT} + end; + NS when ?IS_ORDSET(NS) -> + case unify_types(NType, NT = ?ORDTYPE(NS)) of + [] -> type_mismatch; + NT -> {?ORDDATA(NS), NT} + end; + _ -> + badarg + end. + +%% Inlined. +term2set(L, Type) when is_list(L) -> + ?SET(L, Type); +term2set(T, Type) -> + ?ORDSET(T, Type). + +fam2digraph(F, G) -> + Fun = fun({From, ToL}) -> + digraph:add_vertex(G, From), + Fun2 = fun(To) -> + digraph:add_vertex(G, To), + case digraph:add_edge(G, From, To) of + {error, {bad_edge, _}} -> + throw({error, cyclic}); + _ -> + true + end + end, + foreach(Fun2, ToL) + end, + foreach(Fun, to_external(F)), + G. + +digraph_family(G) -> + Vs = sort(digraph:vertices(G)), + digraph_fam(Vs, Vs, G, []). + +digraph_fam([V | Vs], V0, G, L) when V /= V0 -> + Ns = sort(digraph:out_neighbours(G, V)), + digraph_fam(Vs, V, G, [{V,Ns} | L]); +digraph_fam([], _V0, _G, L) -> + reverse(L). + +%% -> boolean() +check_fun(T, F, FunT) -> + true = is_type(FunT), + {NT, _MaxI} = number_tuples(T, 1), + L = flatten(tuple2list(F(NT))), + has_hole(L, 1). + +number_tuples(T, N) when is_tuple(T) -> + {L, NN} = mapfoldl(fun number_tuples/2, N, tuple_to_list(T)), + {list_to_tuple(L), NN}; +number_tuples(_, N) -> + {N, N+1}. + +tuple2list(T) when is_tuple(T) -> + map(fun tuple2list/1, tuple_to_list(T)); +tuple2list(C) -> + [C]. + +has_hole([I | Is], I0) when I =< I0 -> has_hole(Is, erlang:max(I+1, I0)); +has_hole(Is, _I) -> Is =/= []. + +%% Optimization. Same as check_fun/3, but for integers. +check_for_sort(T, _I) when T =:= ?ANYTYPE -> + empty; +check_for_sort(T, I) when ?IS_RELATION(T), I =< ?REL_ARITY(T), I >= 1 -> + I > 1; +check_for_sort(_T, _I) -> + error. + +inverse_substitution(L, Fun, Sort) -> + %% One easily sees that the inverse of the tuples created by + %% applying Fun need to be sorted iff the tuples created by Fun + %% need to be sorted. + sort(Sort, fun_rearr(L, Fun, [])). + +fun_rearr([E | Es], Fun, L) -> + fun_rearr(Es, Fun, [{Fun(E), E} | L]); +fun_rearr([], _Fun, L) -> + L. + +sets_to_list(Ss) -> + map(fun(S) when ?IS_SET(S) -> ?LIST(S) end, Ss). + +types([], L) -> + list_to_tuple(reverse(L)); +types([S | _Ss], _L) when ?TYPE(S) =:= ?ANYTYPE -> + ?ANYTYPE; +types([S | Ss], L) -> + types(Ss, [?TYPE(S) | L]). + +%% Inlined. +unify_types(T, T) -> T; +unify_types(Type1, Type2) -> + catch unify_types1(Type1, Type2). + +unify_types1(Atom, Atom) when ?IS_ATOM_TYPE(Atom) -> + Atom; +unify_types1(?ANYTYPE, Type) -> + Type; +unify_types1(Type, ?ANYTYPE) -> + Type; +unify_types1(?SET_OF(Type1), ?SET_OF(Type2)) -> + [unify_types1(Type1, Type2)]; +unify_types1(T1, T2) when tuple_size(T1) =:= tuple_size(T2) -> + unify_typesl(tuple_size(T1), T1, T2, []); +unify_types1(_T1, _T2) -> + throw([]). + +unify_typesl(0, _T1, _T2, L) -> + list_to_tuple(L); +unify_typesl(N, T1, T2, L) -> + T = unify_types1(?REL_TYPE(N, T1), ?REL_TYPE(N, T2)), + unify_typesl(N-1, T1, T2, [T | L]). + +%% inlined. +match_types(T, T) -> true; +match_types(Type1, Type2) -> match_types1(Type1, Type2). + +match_types1(Atom, Atom) when ?IS_ATOM_TYPE(Atom) -> + true; +match_types1(?ANYTYPE, _) -> + true; +match_types1(_, ?ANYTYPE) -> + true; +match_types1(?SET_OF(Type1), ?SET_OF(Type2)) -> + match_types1(Type1, Type2); +match_types1(T1, T2) when tuple_size(T1) =:= tuple_size(T2) -> + match_typesl(tuple_size(T1), T1, T2); +match_types1(_T1, _T2) -> + false. + +match_typesl(0, _T1, _T2) -> + true; +match_typesl(N, T1, T2) -> + case match_types1(?REL_TYPE(N, T1), ?REL_TYPE(N, T2)) of + true -> match_typesl(N-1, T1, T2); + false -> false + end. + +sort(true, L) -> + sort(L); +sort(false, L) -> + reverse(L). diff --git a/lib/tools/test/tools_bench.spec b/lib/tools/test/tools_bench.spec new file mode 100644 index 0000000000..ef08fd68a8 --- /dev/null +++ b/lib/tools/test/tools_bench.spec @@ -0,0 +1 @@ +{suites,"../tools_test",[prof_bench_SUITE]}. |