diff options
85 files changed, 1926 insertions, 715 deletions
diff --git a/erts/doc/src/erl_nif.xml b/erts/doc/src/erl_nif.xml index 4bbd4e2a54..cdce4ec0b8 100644 --- a/erts/doc/src/erl_nif.xml +++ b/erts/doc/src/erl_nif.xml @@ -688,6 +688,10 @@ typedef enum { <fsummary>Determine if a term is an empty list</fsummary> <desc><p>Return true if <c>term</c> is an empty list.</p></desc> </func> + <marker id="enif_is_exception"/><func><name><ret>int</ret><nametext>enif_is_exception(ErlNifEnv* env, ERL_NIF_TERM term)</nametext></name> + <fsummary>Determine if a term is an exception</fsummary> + <desc><p>Return true if <c>term</c> is an exception.</p></desc> + </func> <func><name><ret>int</ret><nametext>enif_is_fun(ErlNifEnv* env, ERL_NIF_TERM term)</nametext></name> <fsummary>Determine if a term is a fun</fsummary> <desc><p>Return true if <c>term</c> is a fun.</p></desc> @@ -738,7 +742,14 @@ typedef enum { </func> <func><name><ret>ERL_NIF_TERM</ret><nametext>enif_make_badarg(ErlNifEnv* env)</nametext></name> <fsummary>Make a badarg exception.</fsummary> - <desc><p>Make a badarg exception to be returned from a NIF.</p></desc> + <desc><p>Make a badarg exception to be returned from a NIF, and set + an associated exception reason in <c>env</c>. If + <c>enif_make_badarg</c> is called, the term it returns <em>must</em> + be returned from the function that called it. No other return value + is allowed. Also, the term returned from <c>enif_make_badarg</c> may + be passed only to + <seealso marker="#enif_is_exception">enif_is_exception</seealso> and + not to any other NIF API function.</p></desc> </func> <func><name><ret>ERL_NIF_TERM</ret><nametext>enif_make_binary(ErlNifEnv* env, ErlNifBinary* bin)</nametext></name> <fsummary>Make a binary term.</fsummary> diff --git a/erts/doc/src/notes.xml b/erts/doc/src/notes.xml index 102fa43c1f..e91839572b 100644 --- a/erts/doc/src/notes.xml +++ b/erts/doc/src/notes.xml @@ -30,6 +30,39 @@ </header> <p>This document describes the changes made to the ERTS application.</p> +<section><title>Erts 5.8.3.1</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + Ets table type ordered_set could order large integer keys + wrongly on pure 64bit platforms. This is now corrected.</p> + <p> + Own Id: OTP-9181</p> + </item> + <item> + <p> + The status of a process was unnecessarily set to waiting + before a process was enqueued in a run queue. This bug + was harmless up until OTP-R14B01. In OTP-R14B02 + <c>erlang:hibernate/3</c> was fixed (OTP-9125). After the + introduction of OTP-9125, the previously harmless process + status bug sometimes caused erroneous badarg exceptions + from <c>process_info()</c>.</p> + <p> + OTP-9125 also introduced a thread unsafe access to the + status field of a process which now also have been fixed.</p> + <p> + *** INCOMPATIBILITY with noxs ***</p> + <p> + Own Id: OTP-9197</p> + </item> + </list> + </section> + +</section> + <section><title>Erts 5.8.3</title> <section><title>Fixed Bugs and Malfunctions</title> diff --git a/erts/emulator/beam/beam_debug.c b/erts/emulator/beam/beam_debug.c index 8a48049921..fffb172c68 100644 --- a/erts/emulator/beam/beam_debug.c +++ b/erts/emulator/beam/beam_debug.c @@ -291,7 +291,7 @@ dbg_bt(Process* p, Eterm* sp) if (addr) erts_fprintf(stderr, HEXF ": %T:%T/%bpu\n", - addr, (Eterm) addr[0], (Eterm) addr[1], (Uint) addr[2]); + addr, (Eterm) addr[0], (Eterm) addr[1], addr[2]); } sp++; } @@ -484,7 +484,7 @@ print_op(int to, void *to_arg, int op, int size, BeamInstr* addr) if (f+3 != (BeamInstr *) *ap) { erts_print(to, to_arg, "f(" HEXF ")", *ap); } else { - erts_print(to, to_arg, "%T:%T/%bpu", (Eterm) f[0], (Eterm) f[1], (Eterm) f[2]); + erts_print(to, to_arg, "%T:%T/%bpu", (Eterm) f[0], (Eterm) f[1], f[2]); } ap++; } @@ -495,7 +495,7 @@ print_op(int to, void *to_arg, int op, int size, BeamInstr* addr) if (f+3 != (BeamInstr *) *ap) { erts_print(to, to_arg, "p(" HEXF ")", *ap); } else { - erts_print(to, to_arg, "%T:%T/%bpu", (Eterm) f[0], (Eterm) f[1], (Eterm) f[2]); + erts_print(to, to_arg, "%T:%T/%bpu", (Eterm) f[0], (Eterm) f[1], f[2]); } ap++; } @@ -508,7 +508,7 @@ print_op(int to, void *to_arg, int op, int size, BeamInstr* addr) { Export* ex = (Export *) *ap; erts_print(to, to_arg, - "%T:%T/%bpu", (Eterm) ex->code[0], (Eterm) ex->code[1], (Uint) ex->code[2]); + "%T:%T/%bpu", (Eterm) ex->code[0], (Eterm) ex->code[1], ex->code[2]); ap++; } break; diff --git a/erts/emulator/beam/beam_emu.c b/erts/emulator/beam/beam_emu.c index 8991f7b198..32ea8588d2 100644 --- a/erts/emulator/beam/beam_emu.c +++ b/erts/emulator/beam/beam_emu.c @@ -3420,7 +3420,8 @@ void process_main(void) r(0) = c_p->def_arg_reg[0]; x(1) = c_p->def_arg_reg[1]; x(2) = c_p->def_arg_reg[2]; - if (c_p->status == P_WAITING) { + if (c_p->flags & F_HIBERNATE_SCHED) { + c_p->flags &= ~F_HIBERNATE_SCHED; goto do_schedule; } Dispatch(); @@ -5225,6 +5226,7 @@ void process_main(void) OpCase(i_hibernate): { SWAPOUT; if (erts_hibernate(c_p, r(0), x(1), x(2), reg)) { + c_p->flags &= ~F_HIBERNATE_SCHED; goto do_schedule; } else { I = handle_error(c_p, I, reg, hibernate_3); @@ -6277,15 +6279,17 @@ erts_hibernate(Process* c_p, Eterm module, Eterm function, Eterm args, Eterm* re PROCESS_MAIN_CHK_LOCKS(c_p); erts_smp_proc_lock(c_p, ERTS_PROC_LOCK_MSGQ|ERTS_PROC_LOCK_STATUS); ASSERT(!ERTS_PROC_IS_EXITING(c_p)); - c_p->status = P_WAITING; #ifdef ERTS_SMP ERTS_SMP_MSGQ_MV_INQ2PRIVQ(c_p); if (c_p->msg.len > 0) erts_add_to_runq(c_p); + else #endif + c_p->status = P_WAITING; } erts_smp_proc_unlock(c_p, ERTS_PROC_LOCK_MSGQ|ERTS_PROC_LOCK_STATUS); c_p->current = bif_export[BIF_hibernate_3]->code; + c_p->flags |= F_HIBERNATE_SCHED; /* Needed also when woken! */ return 1; } diff --git a/erts/emulator/beam/break.c b/erts/emulator/beam/break.c index d255cf3558..b8889e6206 100644 --- a/erts/emulator/beam/break.c +++ b/erts/emulator/beam/break.c @@ -1,7 +1,7 @@ /* * %CopyrightBegin% * - * Copyright Ericsson AB 1996-2010. All Rights Reserved. + * Copyright Ericsson AB 1996-2011. All Rights Reserved. * * The contents of this file are subject to the Erlang Public License, * Version 1.1, (the "License"); you may not use this file except in @@ -266,7 +266,7 @@ print_process_info(int to, void *to_arg, Process *p) } erts_print(to, to_arg, "Number of heap fragments: %d\n", frags); } - erts_print(to, to_arg, "Heap fragment data: %bpu\n", MBUF_SIZE(p)); + erts_print(to, to_arg, "Heap fragment data: %beu\n", MBUF_SIZE(p)); scb = ERTS_PROC_GET_SAVED_CALLS_BUF(p); if (scb) { @@ -313,12 +313,11 @@ print_process_info(int to, void *to_arg, Process *p) } /* print the number of reductions etc */ - erts_print(to, to_arg, "Reductions: %bpu\n", p->reds); + erts_print(to, to_arg, "Reductions: %beu\n", p->reds); - erts_print(to, to_arg, "Stack+heap: %bpu\n", p->heap_sz); + erts_print(to, to_arg, "Stack+heap: %beu\n", p->heap_sz); erts_print(to, to_arg, "OldHeap: %bpu\n", - (OLD_HEAP(p) == NULL) ? 0 : - (unsigned)(OLD_HEND(p) - OLD_HEAP(p)) ); + (OLD_HEAP(p) == NULL) ? 0 : (OLD_HEND(p) - OLD_HEAP(p)) ); erts_print(to, to_arg, "Heap unused: %bpu\n", (p->hend - p->htop)); erts_print(to, to_arg, "OldHeap unused: %bpu\n", (OLD_HEAP(p) == NULL) ? 0 : (OLD_HEND(p) - OLD_HTOP(p)) ); diff --git a/erts/emulator/beam/copy.c b/erts/emulator/beam/copy.c index 243e8973cf..90201f3a90 100644 --- a/erts/emulator/beam/copy.c +++ b/erts/emulator/beam/copy.c @@ -477,7 +477,7 @@ Eterm copy_struct(Eterm obj, Uint sz, Eterm** hpp, ErlOffHeap* off_heap) if (htop != hbot) erl_exit(ERTS_ABORT_EXIT, "Internal error in copy_struct() when copying %T:" - " htop=%p != hbot=%p (sz=%bpu)\n", + " htop=%p != hbot=%p (sz=%beu)\n", org_obj, htop, hbot, org_sz); #else if (htop > hbot) { diff --git a/erts/emulator/beam/dist.c b/erts/emulator/beam/dist.c index 05eddf4ae0..b1cdd0660a 100644 --- a/erts/emulator/beam/dist.c +++ b/erts/emulator/beam/dist.c @@ -1687,7 +1687,7 @@ dist_port_command(Port *prt, ErtsDistOutputBuf *obuf) if (size > (Uint) INT_MAX) erl_exit(ERTS_ABORT_EXIT, "Absurdly large distribution output data buffer " - "(%bpu bytes) passed.\n", + "(%beu bytes) passed.\n", size); prt->caller = NIL; @@ -1714,7 +1714,7 @@ dist_port_commandv(Port *prt, ErtsDistOutputBuf *obuf) if (size > (Uint) INT_MAX) erl_exit(ERTS_ABORT_EXIT, "Absurdly large distribution output data buffer " - "(%bpu bytes) passed.\n", + "(%beu bytes) passed.\n", size); iov[0].iov_base = NULL; diff --git a/erts/emulator/beam/erl_alloc.c b/erts/emulator/beam/erl_alloc.c index 775f4435a9..673eac7fea 100644 --- a/erts/emulator/beam/erl_alloc.c +++ b/erts/emulator/beam/erl_alloc.c @@ -1913,7 +1913,7 @@ erts_memory(int *print_to_p, void *print_to_arg, void *proc, Eterm earg) /* Print result... */ erts_print(to, arg, "=memory\n"); for (i = 0; i < length; i++) - erts_print(to, arg, "%T: %bpu\n", atoms[i], *uintps[i]); + erts_print(to, arg, "%T: %beu\n", atoms[i], *uintps[i]); } if (proc) { @@ -2107,11 +2107,11 @@ erts_allocated_areas(int *print_to_p, void *print_to_arg, void *proc) for (i = 0; i < length; i++) { switch (values[i].arity) { case 2: - erts_print(to, arg, "%s: %bpu\n", + erts_print(to, arg, "%s: %beu\n", values[i].name, values[i].ui[0]); break; case 3: - erts_print(to, arg, "%s: %bpu %bpu\n", + erts_print(to, arg, "%s: %beu %beu\n", values[i].name, values[i].ui[0], values[i].ui[1]); break; default: diff --git a/erts/emulator/beam/erl_alloc_util.c b/erts/emulator/beam/erl_alloc_util.c index 1394b7e829..84c72439a3 100644 --- a/erts/emulator/beam/erl_alloc_util.c +++ b/erts/emulator/beam/erl_alloc_util.c @@ -1877,7 +1877,7 @@ sz_info_carriers(Allctr_t *allctr, cs->blocks.max_ever.size); erts_print(to, arg, - "%scarriers size: %bpu %bpu %bpu\n", + "%scarriers size: %beu %bpu %bpu\n", prefix, curr_size, cs->max.size, @@ -1933,7 +1933,7 @@ info_carriers(Allctr_t *allctr, cs->blocks.max_ever.size); erts_print(to, arg, - "%scarriers: %bpu %bpu %bpu\n", + "%scarriers: %beu %bpu %bpu\n", prefix, curr_no, cs->max.no, @@ -1952,7 +1952,7 @@ info_carriers(Allctr_t *allctr, cs->curr_sys_alloc.no); erts_print(to, arg, - "%scarriers size: %bpu %bpu %bpu\n", + "%scarriers size: %beu %bpu %bpu\n", prefix, curr_size, cs->max.size, @@ -2053,15 +2053,15 @@ info_calls(Allctr_t *allctr, #define PRINT_CC_4(TO, TOA, NAME, CC) \ if ((CC).giga_no == 0) \ - erts_print(TO, TOA, "%s calls: %bpu\n", NAME, CC.no); \ + erts_print(TO, TOA, "%s calls: %b32u\n", NAME, CC.no); \ else \ - erts_print(TO, TOA, "%s calls: %bpu%09lu\n", NAME, CC.giga_no, CC.no) + erts_print(TO, TOA, "%s calls: %b32u%09lu\n", NAME, CC.giga_no, CC.no) #define PRINT_CC_5(TO, TOA, PRFX, NAME, CC) \ if ((CC).giga_no == 0) \ - erts_print(TO, TOA, "%s%s calls: %bpu\n",PRFX,NAME,CC.no); \ + erts_print(TO, TOA, "%s%s calls: %b32u\n",PRFX,NAME,CC.no); \ else \ - erts_print(TO, TOA, "%s%s calls: %bpu%09lu\n",PRFX,NAME,CC.giga_no,CC.no) + erts_print(TO, TOA, "%s%s calls: %b32u%09lu\n",PRFX,NAME,CC.giga_no,CC.no) char *prefix = allctr->name_prefix; int to = *print_to_p; @@ -2168,21 +2168,21 @@ info_options(Allctr_t *allctr, "option e: true\n" "option t: %s\n" "option ramv: %s\n" - "option sbct: %bpu\n" + "option sbct: %beu\n" #if HAVE_ERTS_MSEG "option asbcst: %bpu\n" "option rsbcst: %bpu\n" #endif - "option rsbcmt: %bpu\n" - "option rmbcmt: %bpu\n" - "option mmbcs: %bpu\n" + "option rsbcmt: %beu\n" + "option rmbcmt: %beu\n" + "option mmbcs: %beu\n" #if HAVE_ERTS_MSEG - "option mmsbc: %bpu\n" - "option mmmbc: %bpu\n" + "option mmsbc: %beu\n" + "option mmmbc: %beu\n" #endif - "option lmbcs: %bpu\n" - "option smbcs: %bpu\n" - "option mbcgs: %bpu\n", + "option lmbcs: %beu\n" + "option smbcs: %beu\n" + "option mbcgs: %beu\n", topt, allctr->ramv ? "true" : "false", allctr->sbc_threshold, @@ -2292,9 +2292,9 @@ erts_alcu_au_info_options(int *print_to_p, void *print_to_arg, erts_print(*print_to_p, print_to_arg, #if HAVE_ERTS_MSEG - "option mmc: %bpu\n" + "option mmc: %beu\n" #endif - "option ycs: %bpu\n", + "option ycs: %beu\n", #if HAVE_ERTS_MSEG max_mseg_carriers, #endif diff --git a/erts/emulator/beam/erl_bif_info.c b/erts/emulator/beam/erl_bif_info.c index 71206c48b2..e50fc18e64 100644 --- a/erts/emulator/beam/erl_bif_info.c +++ b/erts/emulator/beam/erl_bif_info.c @@ -71,9 +71,9 @@ static char erts_system_version[] = ("Erlang " ERLANG_OTP_RELEASE #endif #endif #ifdef ERTS_SMP - " [smp:%bpu:%bpu]" + " [smp:%beu:%beu]" #endif - " [rq:%bpu]" + " [rq:%beu]" #ifdef USE_THREADS " [async-threads:%d]" #endif diff --git a/erts/emulator/beam/erl_db.c b/erts/emulator/beam/erl_db.c index 61e8a595be..e0a6aa05c6 100644 --- a/erts/emulator/beam/erl_db.c +++ b/erts/emulator/beam/erl_db.c @@ -3737,7 +3737,7 @@ static void print_table(int to, void *to_arg, int show, DbTable* tb) erts_print(to, to_arg, "Objects: %d\n", (int)erts_smp_atomic_read(&tb->common.nitems)); erts_print(to, to_arg, "Words: %bpu\n", - (Uint) ((erts_smp_atomic_read(&tb->common.memory_size) + (UWord) ((erts_smp_atomic_read(&tb->common.memory_size) + sizeof(Uint) - 1) / sizeof(Uint))); diff --git a/erts/emulator/beam/erl_db_tree.c b/erts/emulator/beam/erl_db_tree.c index 6cdbec3213..a59c0c258d 100644 --- a/erts/emulator/beam/erl_db_tree.c +++ b/erts/emulator/beam/erl_db_tree.c @@ -575,7 +575,7 @@ static int db_prev_tree(Process *p, DbTable *tbl, Eterm key, Eterm *ret) return DB_ERROR_NONE; } -static ERTS_INLINE int cmp_key(DbTableTree* tb, Eterm key, Eterm* key_base, +static ERTS_INLINE Sint cmp_key(DbTableTree* tb, Eterm key, Eterm* key_base, TreeDbTerm* obj) { return cmp_rel(key, key_base, diff --git a/erts/emulator/beam/erl_db_util.c b/erts/emulator/beam/erl_db_util.c index 0b63ab9ba0..c3b074f782 100644 --- a/erts/emulator/beam/erl_db_util.c +++ b/erts/emulator/beam/erl_db_util.c @@ -5046,31 +5046,31 @@ void db_match_dis(Binary *bp) ++t; n = *t; ++t; - erts_printf("TryMeElse\t%bpu\n", n); + erts_printf("TryMeElse\t%beu\n", n); break; case matchArray: ++t; n = *t; ++t; - erts_printf("Array\t%bpu\n", n); + erts_printf("Array\t%beu\n", n); break; case matchArrayBind: ++t; n = *t; ++t; - erts_printf("ArrayBind\t%bpu\n", n); + erts_printf("ArrayBind\t%beu\n", n); break; case matchTuple: ++t; n = *t; ++t; - erts_printf("Tuple\t%bpu\n", n); + erts_printf("Tuple\t%beu\n", n); break; case matchPushT: ++t; n = *t; ++t; - erts_printf("PushT\t%bpu\n", n); + erts_printf("PushT\t%beu\n", n); break; case matchPushL: ++t; @@ -5084,13 +5084,13 @@ void db_match_dis(Binary *bp) ++t; n = *t; ++t; - erts_printf("Bind\t%bpu\n", n); + erts_printf("Bind\t%beu\n", n); break; case matchCmp: ++t; n = *t; ++t; - erts_printf("Cmp\t%bpu\n", n); + erts_printf("Cmp\t%beu\n", n); break; case matchEqBin: ++t; @@ -5112,9 +5112,9 @@ void db_match_dis(Binary *bp) else erts_printf(", "); #if defined(ARCH_64) && !HALFWORD_HEAP - erts_printf("0x%016bpx", rt->data.ui[ri]); + erts_printf("0x%016bex", rt->data.ui[ri]); #else - erts_printf("0x%08bpx", rt->data.ui[ri]); + erts_printf("0x%08bex", rt->data.ui[ri]); #endif } } @@ -5136,9 +5136,9 @@ void db_match_dis(Binary *bp) else erts_printf(", "); #if defined(ARCH_64) && !HALFWORD_HEAP - erts_printf("0x%016bpx", *et); + erts_printf("0x%016bex", *et); #else - erts_printf("0x%08bpx", *et); + erts_printf("0x%08bex", *et); #endif ++et; } @@ -5190,31 +5190,31 @@ void db_match_dis(Binary *bp) ++t; n = *t; ++t; - erts_printf("MkTuple\t%bpu\n", n); + erts_printf("MkTuple\t%beu\n", n); break; case matchOr: ++t; n = *t; ++t; - erts_printf("Or\t%bpu\n", n); + erts_printf("Or\t%beu\n", n); break; case matchAnd: ++t; n = *t; ++t; - erts_printf("And\t%bpu\n", n); + erts_printf("And\t%beu\n", n); break; case matchOrElse: ++t; n = *t; ++t; - erts_printf("OrElse\t%bpu\n", n); + erts_printf("OrElse\t%beu\n", n); break; case matchAndAlso: ++t; n = *t; ++t; - erts_printf("AndAlso\t%bpu\n", n); + erts_printf("AndAlso\t%beu\n", n); break; case matchCall0: ++t; @@ -5244,19 +5244,19 @@ void db_match_dis(Binary *bp) ++t; n = (Uint) *t; ++t; - erts_printf("PushV\t%bpu\n", n); + erts_printf("PushV\t%beu\n", n); break; #if HALFWORD_HEAP case matchPushVGuard: n = (Uint) *++t; ++t; - erts_printf("PushVGuard\t%bpu\n", n); + erts_printf("PushVGuard\t%beu\n", n); break; #endif case matchPushVResult: n = (Uint) *++t; ++t; - erts_printf("PushVResult\t%bpu\n", n); + erts_printf("PushVResult\t%beu\n", n); break; case matchTrue: ++t; @@ -5367,8 +5367,8 @@ void db_match_dis(Binary *bp) } erts_printf("}\n"); erts_printf("num_bindings: %d\n", prog->num_bindings); - erts_printf("heap_size: %bpu\n", prog->heap_size); - erts_printf("stack_offset: %bpu\n", prog->stack_offset); + erts_printf("heap_size: %beu\n", prog->heap_size); + erts_printf("stack_offset: %beu\n", prog->stack_offset); erts_printf("text: 0x%08x\n", (unsigned long) prog->text); erts_printf("stack_size: %d (words)\n", prog->heap_size-prog->stack_offset); diff --git a/erts/emulator/beam/erl_nif.c b/erts/emulator/beam/erl_nif.c index 135c6b0ccc..8b48444904 100644 --- a/erts/emulator/beam/erl_nif.c +++ b/erts/emulator/beam/erl_nif.c @@ -430,6 +430,11 @@ int enif_is_list(ErlNifEnv* env, ERL_NIF_TERM term) return is_list(term) || is_nil(term); } +int enif_is_exception(ErlNifEnv* env, ERL_NIF_TERM term) +{ + return term == THE_NON_VALUE; +} + static void aligned_binary_dtor(struct enif_tmp_obj_t* obj) { erts_free_aligned_binary_bytes_extra((byte*)obj,ERTS_ALC_T_TMP); diff --git a/erts/emulator/beam/erl_nif.h b/erts/emulator/beam/erl_nif.h index 8050b3640a..d028567faf 100644 --- a/erts/emulator/beam/erl_nif.h +++ b/erts/emulator/beam/erl_nif.h @@ -31,9 +31,10 @@ ** 1.0: R13B04 ** 2.0: R14A ** 2.1: R14B02 "vm_variant" +** 2.2: R14B03 enif_is_exception */ #define ERL_NIF_MAJOR_VERSION 2 -#define ERL_NIF_MINOR_VERSION 1 +#define ERL_NIF_MINOR_VERSION 2 #include <stdlib.h> diff --git a/erts/emulator/beam/erl_nif_api_funcs.h b/erts/emulator/beam/erl_nif_api_funcs.h index eca506593d..c991b61abe 100644 --- a/erts/emulator/beam/erl_nif_api_funcs.h +++ b/erts/emulator/beam/erl_nif_api_funcs.h @@ -1,7 +1,7 @@ /* * %CopyrightBegin% * - * Copyright Ericsson AB 2009-2010. All Rights Reserved. + * Copyright Ericsson AB 2009-2011. All Rights Reserved. * * The contents of this file are subject to the Erlang Public License, * Version 1.1, (the "License"); you may not use this file except in @@ -21,6 +21,13 @@ # error This file should not be included directly #endif +/* +** WARNING: add new ERL_NIF_API_FUNC_DECL entries at the bottom of the list +** to keep compatibility on Windows!!! +** +** And don't forget to increase ERL_NIF_MINOR_VERSION in erl_nif.h +** when adding functions to the API. +*/ #ifdef ERL_NIF_API_FUNC_DECL ERL_NIF_API_FUNC_DECL(void*,enif_priv_data,(ErlNifEnv*)); ERL_NIF_API_FUNC_DECL(void*,enif_alloc,(size_t size)); @@ -128,12 +135,17 @@ ERL_NIF_API_FUNC_DECL(int,enif_get_uint64,(ErlNifEnv*, ERL_NIF_TERM term, ErlNif ERL_NIF_API_FUNC_DECL(ERL_NIF_TERM,enif_make_int64,(ErlNifEnv*, ErlNifSInt64)); ERL_NIF_API_FUNC_DECL(ERL_NIF_TERM,enif_make_uint64,(ErlNifEnv*, ErlNifUInt64)); #endif +ERL_NIF_API_FUNC_DECL(int,enif_is_exception,(ErlNifEnv*, ERL_NIF_TERM term)); /* -** Add last to keep compatibility on Windows!!! +** Add new entries here to keep compatibility on Windows!!! */ #endif +/* +** Please keep the ERL_NIF_API_FUNC_MACRO list below in the same order +** as the ERL_NIF_API_FUNC_DECL list above +*/ #ifdef ERL_NIF_API_FUNC_MACRO # define enif_priv_data ERL_NIF_API_FUNC_MACRO(enif_priv_data) # define enif_alloc ERL_NIF_API_FUNC_MACRO(enif_alloc) @@ -243,6 +255,11 @@ ERL_NIF_API_FUNC_DECL(ERL_NIF_TERM,enif_make_uint64,(ErlNifEnv*, ErlNifUInt64)); # define enif_make_uint64 ERL_NIF_API_FUNC_MACRO(enif_make_uint64) #endif +# define enif_is_exception ERL_NIF_API_FUNC_MACRO(enif_is_exception) + +/* +** Add new entries here +*/ #endif #ifndef enif_make_list1 diff --git a/erts/emulator/beam/erl_process.c b/erts/emulator/beam/erl_process.c index 21ee72edf2..31f23d3978 100644 --- a/erts/emulator/beam/erl_process.c +++ b/erts/emulator/beam/erl_process.c @@ -2855,7 +2855,6 @@ resume_process(Process *p) return; switch(p->rstatus) { case P_RUNABLE: - *statusp = P_WAITING; /* make erts_add_to_runq work */ erts_add_to_runq(p); break; case P_WAITING: @@ -3666,7 +3665,7 @@ sched_thread_func(void *vesdp) #ifdef ERTS_ENABLE_LOCK_CHECK { char buf[31]; - erts_snprintf(&buf[0], 31, "scheduler %bpu", no); + erts_snprintf(&buf[0], 31, "scheduler %beu", no); erts_lc_set_thread_name(&buf[0]); } #endif @@ -3724,7 +3723,7 @@ sched_thread_func(void *vesdp) process_main(); /* No schedulers should *ever* terminate */ - erl_exit(ERTS_ABORT_EXIT, "Scheduler thread number %bpu terminated\n", + erl_exit(ERTS_ABORT_EXIT, "Scheduler thread number %beu terminated\n", ((ErtsSchedulerData *) vesdp)->no); return NULL; } @@ -3773,8 +3772,8 @@ erts_start_schedulers(void) erts_dsprintf_buf_t *dsbufp = erts_create_logger_dsbuf(); ASSERT(actual != wanted_no_schedulers); erts_dsprintf(dsbufp, - "Failed to create %bpu scheduler-threads (%s:%d); " - "only %bpu scheduler-thread%s created.\n", + "Failed to create %beu scheduler-threads (%s:%d); " + "only %beu scheduler-thread%s created.\n", wanted_no_schedulers, erl_errno_id(res), res, actual, actual == 1 ? " was" : "s were"); erts_send_error_to_logger_nogl(dsbufp); @@ -4651,7 +4650,7 @@ internal_add_to_runq(ErtsRunQueue *runq, Process *p) if (p->status_flags & ERTS_PROC_SFLG_INRUNQ) return NULL; else if (p->runq_flags & ERTS_PROC_RUNQ_FLG_RUNNING) { - ASSERT(p->status != P_SUSPENDED); + ASSERT(p->rcount == 0); ERTS_DBG_CHK_PROCS_RUNQ_NOPROC(runq, p); p->status_flags |= ERTS_PROC_SFLG_PENDADD2SCHEDQ; return NULL; @@ -4662,9 +4661,8 @@ internal_add_to_runq(ErtsRunQueue *runq, Process *p) ERTS_DBG_CHK_PROCS_RUNQ_NOPROC(runq, p); #ifndef ERTS_SMP /* Never schedule a suspended process (ok in smp case) */ - ASSERT(p->status != P_SUSPENDED); + ASSERT(p->rcount == 0); add_runq = runq; - #else ASSERT(!p->bound_runq || p->bound_runq == p->run_queue); if (p->bound_runq) { @@ -5164,7 +5162,7 @@ Process *schedule(Process *p, int calls) handle_pending_suspend(p, ERTS_PROC_LOCK_MAIN|ERTS_PROC_LOCK_STATUS); ASSERT(!(p->status_flags & ERTS_PROC_SFLG_PENDADD2SCHEDQ) - || p->status != P_SUSPENDED); + || p->rcount == 0); } #endif erts_smp_runq_lock(rq); @@ -7609,10 +7607,28 @@ timeout_proc(Process* p) p->flags |= F_TIMO; p->flags &= ~F_INSLPQUEUE; - if (p->status == P_WAITING) - erts_add_to_runq(p); - if (p->status == P_SUSPENDED) + switch (p->status) { + case P_GARBING: + switch (p->gcstatus) { + case P_SUSPENDED: + goto suspended; + case P_WAITING: + goto waiting; + default: + break; + } + break; + case P_WAITING: + waiting: + erts_add_to_runq(p); + break; + case P_SUSPENDED: + suspended: p->rstatus = P_RUNABLE; /* MUST set resume status to runnable */ + break; + default: + break; + } } diff --git a/erts/emulator/beam/erl_process.h b/erts/emulator/beam/erl_process.h index 8f78a7d76e..334ae5573f 100644 --- a/erts/emulator/beam/erl_process.h +++ b/erts/emulator/beam/erl_process.h @@ -895,6 +895,7 @@ extern struct erts_system_profile_flags_t erts_system_profile_flags; #define F_HAVE_BLCKD_MSCHED (1 << 8) /* Process has blocked multi-scheduling */ #define F_P2PNR_RESCHED (1 << 9) /* Process has been rescheduled via erts_pid2proc_not_running() */ #define F_FORCE_GC (1 << 10) /* Force gc at process in-scheduling */ +#define F_HIBERNATE_SCHED (1 << 11) /* Schedule out after hibernate op */ /* process trace_flags */ #define F_SENSITIVE (1 << 0) diff --git a/erts/emulator/beam/erl_process_dump.c b/erts/emulator/beam/erl_process_dump.c index 68fda01597..5410bcd495 100644 --- a/erts/emulator/beam/erl_process_dump.c +++ b/erts/emulator/beam/erl_process_dump.c @@ -194,7 +194,7 @@ dump_element(int to, void *to_arg, Eterm x) } else if (is_pid(x)) { erts_print(to, to_arg, "P%T", x); } else if (is_port(x)) { - erts_print(to, to_arg, "p<%bpu.%bpu>", + erts_print(to, to_arg, "p<%beu.%beu>", port_channel_no(x), port_number(x)); } else if (is_nil(x)) { erts_putc(to, to_arg, 'N'); @@ -376,7 +376,7 @@ heap_dump(int to, void *to_arg, Eterm x) erts_print(to, to_arg, "P%T\n", x); *ptr = OUR_NIL; } else if (is_external_port_header(hdr)) { - erts_print(to, to_arg, "p<%bpu.%bpu>\n", + erts_print(to, to_arg, "p<%beu.%beu>\n", port_channel_no(x), port_number(x)); *ptr = OUR_NIL; } else { diff --git a/erts/emulator/beam/global.h b/erts/emulator/beam/global.h index 432bdd705b..96da894d90 100644 --- a/erts/emulator/beam/global.h +++ b/erts/emulator/beam/global.h @@ -1828,7 +1828,7 @@ erts_alloc_message_heap(Uint size, #endif if (size > (Uint) INT_MAX) - erl_exit(ERTS_ABORT_EXIT, "HUGE size (%bpu)\n", size); + erl_exit(ERTS_ABORT_EXIT, "HUGE size (%beu)\n", size); if ( #if defined(ERTS_SMP) diff --git a/erts/emulator/beam/io.c b/erts/emulator/beam/io.c index 2e884a350e..f619c6f88b 100644 --- a/erts/emulator/beam/io.c +++ b/erts/emulator/beam/io.c @@ -1,7 +1,7 @@ /* * %CopyrightBegin% * - * Copyright Ericsson AB 1996-2010. All Rights Reserved. + * Copyright Ericsson AB 1996-2011. All Rights Reserved. * * The contents of this file are subject to the Erlang Public License, * Version 1.1, (the "License"); you may not use this file except in @@ -2417,7 +2417,7 @@ void erts_raw_port_command(Port* p, byte* buf, Uint len) if (len > (Uint) INT_MAX) erl_exit(ERTS_ABORT_EXIT, - "Absurdly large data buffer (%bpu bytes) passed to" + "Absurdly large data buffer (%beu bytes) passed to" "output callback of %s driver.\n", len, p->drv_ptr->name ? p->drv_ptr->name : "unknown"); @@ -3667,7 +3667,7 @@ driver_pdl_inc_refc(ErlDrvPDL pdl) { ErlDrvSInt refc = pdl_inctest_refc(pdl); #ifdef HARDDEBUG - erts_fprintf(stderr, "driver_pdl_inc_refc(%p) -> %bpd\r\n", + erts_fprintf(stderr, "driver_pdl_inc_refc(%p) -> %bed\r\n", pdl, refc); #endif return refc; diff --git a/erts/emulator/hipe/hipe_debug.c b/erts/emulator/hipe/hipe_debug.c index c7b608aafe..7ca11f8c6c 100644 --- a/erts/emulator/hipe/hipe_debug.c +++ b/erts/emulator/hipe/hipe_debug.c @@ -51,7 +51,7 @@ static const char stars[2*sizeof(long)+5] = { extern Uint beam_apply[]; -static void print_beam_pc(Uint *pc) +static void print_beam_pc(BeamInstr *pc) { if (pc == hipe_beam_pc_return) { printf("return-to-native"); @@ -60,7 +60,7 @@ static void print_beam_pc(Uint *pc) } else if (pc == &beam_apply[1]) { printf("normal-process-exit"); } else { - Eterm *mfa = find_function_from_pc(pc); + BeamInstr *mfa = find_function_from_pc(pc); if (mfa) erts_printf("%T:%T/%bpu + 0x%bpx", mfa[0], mfa[1], mfa[2], pc - &mfa[3]); @@ -71,7 +71,7 @@ static void print_beam_pc(Uint *pc) static void catch_slot(Eterm *pos, Eterm val) { - Uint *pc = catch_pc(val); + BeamInstr *pc = catch_pc(val); printf(" | 0x%0*lx | 0x%0*lx | CATCH 0x%0*lx (BEAM ", 2*(int)sizeof(long), (unsigned long)pos, 2*(int)sizeof(long), (unsigned long)val, diff --git a/erts/emulator/sys/common/erl_mseg.c b/erts/emulator/sys/common/erl_mseg.c index ceb290b644..ffa3a6328c 100644 --- a/erts/emulator/sys/common/erl_mseg.c +++ b/erts/emulator/sys/common/erl_mseg.c @@ -1092,10 +1092,10 @@ info_options(char *prefix, if (print_to_p) { int to = *print_to_p; void *arg = print_to_arg; - erts_print(to, arg, "%samcbf: %bpu\n", prefix, abs_max_cache_bad_fit); - erts_print(to, arg, "%srmcbf: %bpu\n", prefix, rel_max_cache_bad_fit); - erts_print(to, arg, "%smcs: %bpu\n", prefix, max_cache_size); - erts_print(to, arg, "%scci: %bpu\n", prefix, cache_check_interval); + erts_print(to, arg, "%samcbf: %beu\n", prefix, abs_max_cache_bad_fit); + erts_print(to, arg, "%srmcbf: %beu\n", prefix, rel_max_cache_bad_fit); + erts_print(to, arg, "%smcs: %beu\n", prefix, max_cache_size); + erts_print(to, arg, "%scci: %beu\n", prefix, cache_check_interval); } if (hpp || szp) { @@ -1131,9 +1131,9 @@ info_calls(int *print_to_p, void *print_to_arg, Uint **hpp, Uint *szp) #define PRINT_CC(TO, TOA, CC) \ if (calls.CC.giga_no == 0) \ - erts_print(TO, TOA, "mseg_%s calls: %bpu\n", #CC, calls.CC.no); \ + erts_print(TO, TOA, "mseg_%s calls: %b32u\n", #CC, calls.CC.no); \ else \ - erts_print(TO, TOA, "mseg_%s calls: %bpu%09bpu\n", #CC, \ + erts_print(TO, TOA, "mseg_%s calls: %b32u%09b32u\n", #CC, \ calls.CC.giga_no, calls.CC.no) int to = *print_to_p; @@ -1215,13 +1215,13 @@ info_status(MemKind* mk, int *print_to_p, void *print_to_arg, int to = *print_to_p; void *arg = print_to_arg; - erts_print(to, arg, "cached_segments: %bpu\n", mk->cache_size); - erts_print(to, arg, "cache_hits: %bpu\n", mk->cache_hits); - erts_print(to, arg, "segments: %bpu %bpu %bpu\n", + erts_print(to, arg, "cached_segments: %beu\n", mk->cache_size); + erts_print(to, arg, "cache_hits: %beu\n", mk->cache_hits); + erts_print(to, arg, "segments: %beu %beu %beu\n", mk->segments.current.no, mk->segments.max.no, mk->segments.max_ever.no); - erts_print(to, arg, "segments_size: %bpu %bpu %bpu\n", + erts_print(to, arg, "segments_size: %beu %beu %beu\n", mk->segments.current.sz, mk->segments.max.sz, mk->segments.max_ever.sz); - erts_print(to, arg, "segments_watermark: %bpu\n", + erts_print(to, arg, "segments_watermark: %beu\n", mk->segments.current.watermark); } @@ -1507,7 +1507,7 @@ erts_mseg_init(ErtsMsegInit_t *init) while ((page_size >> page_shift) != 1) { if ((page_size & (1 << (page_shift - 1))) != 0) erl_exit(ERTS_ABORT_EXIT, - "erts_mseg: Unexpected page_size %bpu\n", page_size); + "erts_mseg: Unexpected page_size %beu\n", page_size); page_shift++; } diff --git a/erts/emulator/test/code_SUITE.erl b/erts/emulator/test/code_SUITE.erl index 703a00a598..c1a048be75 100644 --- a/erts/emulator/test/code_SUITE.erl +++ b/erts/emulator/test/code_SUITE.erl @@ -483,7 +483,7 @@ do_false_dependency(Init, Code) -> %% Spawn process. Make sure it has the appropriate init function %% and returned. CP should not contain garbage after the return. Parent = self(), - ?line Pid = spawn_link(fun() -> false_dependency_loop(Parent, Init) end), + ?line Pid = spawn_link(fun() -> false_dependency_loop(Parent, Init, true) end), ?line receive initialized -> ok end, %% Reload the module. Make sure the process is still alive. @@ -501,11 +501,18 @@ do_false_dependency(Init, Code) -> ?line true = erlang:purge_module(cpbugx), ok. -false_dependency_loop(Parent, Init) -> +false_dependency_loop(Parent, Init, SendInitAck) -> Init(), - Parent ! initialized, + case SendInitAck of + true -> Parent ! initialized; + false -> void + %% Just send one init-ack. I guess the point of this test + %% wasn't to fill parents msg-queue (?). Seen to cause + %% out-of-mem (on halfword-vm for some reason) by + %% 91 million msg in queue. /sverker + end, receive - _ -> false_dependency_loop(Parent, Init) + _ -> false_dependency_loop(Parent, Init, false) end. coverage(Config) when is_list(Config) -> diff --git a/erts/emulator/test/nif_SUITE.erl b/erts/emulator/test/nif_SUITE.erl index b79c30d8d9..91d695d979 100644 --- a/erts/emulator/test/nif_SUITE.erl +++ b/erts/emulator/test/nif_SUITE.erl @@ -1121,7 +1121,14 @@ is_checks(Config) when is_list(Config) -> ?line ensure_lib_loaded(Config, 1), ?line ok = check_is(hejsan, <<19,98>>, make_ref(), ok, fun() -> ok end, self(), hd(erlang:ports()), [], [1,9,9,8], - {hejsan, "hejsan", [$h,"ejs",<<"an">>]}). + {hejsan, "hejsan", [$h,"ejs",<<"an">>]}), + try + ?line error = check_is_exception(), + ?line throw(expected_badarg) + catch + error:badarg -> + ?line ok + end. get_length(doc) -> ["Test all enif_get_length functions"]; get_length(Config) when is_list(Config) -> @@ -1245,6 +1252,7 @@ release_resource(_) -> ?nif_stub. last_resource_dtor_call() -> ?nif_stub. make_new_resource(_,_) -> ?nif_stub. check_is(_,_,_,_,_,_,_,_,_,_) -> ?nif_stub. +check_is_exception() -> ?nif_stub. length_test(_,_,_,_,_) -> ?nif_stub. make_atoms() -> ?nif_stub. make_strings() -> ?nif_stub. diff --git a/erts/emulator/test/nif_SUITE_data/nif_SUITE.c b/erts/emulator/test/nif_SUITE_data/nif_SUITE.c index 8489124966..dc047394b5 100644 --- a/erts/emulator/test/nif_SUITE_data/nif_SUITE.c +++ b/erts/emulator/test/nif_SUITE_data/nif_SUITE.c @@ -802,6 +802,23 @@ static ERL_NIF_TERM check_is(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[] } /* + * no arguments + * + * This function is separate from check_is because it calls enif_make_badarg + * and so it must return the badarg exception as its return value. Thus, the + * badarg exception indicates success. Failure is indicated by returning an + * error atom. + */ +static ERL_NIF_TERM check_is_exception(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{ + ERL_NIF_TERM error_atom = enif_make_atom(env, "error"); + ERL_NIF_TERM badarg = enif_make_badarg(env); + if (enif_is_exception(env, error_atom)) return error_atom; + if (!enif_is_exception(env, badarg)) return error_atom; + return badarg; +} + +/* * argv[0] atom with length of 6 * argv[1] list with length of 6 * argv[2] empty list @@ -1383,6 +1400,7 @@ static ErlNifFunc nif_funcs[] = {"last_resource_dtor_call", 0, last_resource_dtor_call}, {"make_new_resource", 2, make_new_resource}, {"check_is", 10, check_is}, + {"check_is_exception", 0, check_is_exception}, {"length_test", 5, length_test}, {"make_atoms", 0, make_atoms}, {"make_strings", 0, make_strings}, diff --git a/erts/emulator/test/process_SUITE.erl b/erts/emulator/test/process_SUITE.erl index a731f09e4c..36bae908aa 100644 --- a/erts/emulator/test/process_SUITE.erl +++ b/erts/emulator/test/process_SUITE.erl @@ -39,6 +39,7 @@ process_info_other_dist_msg/1, process_info_2_list/1, process_info_lock_reschedule/1, process_info_lock_reschedule2/1, + process_info_lock_reschedule3/1, bump_reductions/1, low_prio/1, binary_owner/1, yield/1, yield2/1, process_status_exiting/1, otp_4725/1, bad_register/1, garbage_collect/1, otp_6237/1, @@ -65,7 +66,8 @@ all() -> t_process_info, process_info_other_msg, process_info_other_dist_msg, process_info_2_list, process_info_lock_reschedule, - process_info_lock_reschedule2, process_status_exiting, + process_info_lock_reschedule2, + process_info_lock_reschedule3, process_status_exiting, bump_reductions, low_prio, yield, yield2, otp_4725, bad_register, garbage_collect, process_info_messages, process_flag_badarg, process_flag_heap_size, @@ -702,6 +704,52 @@ process_info_lock_reschedule2(Config) when is_list(Config) -> ?line unlink(P6), exit(P6, bang), ?line ok. +many_args(0,_B,_C,_D,_E,_F,_G,_H,_I,_J) -> + ok; +many_args(A,B,C,D,E,F,G,H,I,J) -> + many_args(A-1,B,C,D,E,F,G,H,I,J). + +do_pi_msg_len(PT, AT) -> + lists:map(fun (_) -> ok end, [a,b,c,d]), + {message_queue_len, _} = process_info(element(2,PT), element(2,AT)). + +process_info_lock_reschedule3(doc) -> + []; +process_info_lock_reschedule3(suite) -> + []; +process_info_lock_reschedule3(Config) when is_list(Config) -> + %% We need a process that is running and an item that requires + %% process_info to take the main process lock. + ?line Target1 = spawn_link(fun tok_loop/0), + ?line Name1 = process_info_lock_reschedule_running, + ?line register(Name1, Target1), + ?line Target2 = spawn_link(fun () -> receive after infinity -> ok end end), + ?line Name2 = process_info_lock_reschedule_waiting, + ?line register(Name2, Target2), + ?line PI = fun(N) -> + case N rem 10 of + 0 -> erlang:yield(); + _ -> ok + end, + ?line do_pi_msg_len({proc, Target1}, + {arg, message_queue_len}) + end, + ?line many_args(100000,1,2,3,4,5,6,7,8,9), + ?line lists:foreach(PI, lists:seq(1,1000000)), + %% Make sure Target1 still is willing to "tok loop" + ?line case process_info(Target1, status) of + {status, OkStatus} when OkStatus == runnable; + OkStatus == running; + OkStatus == garbage_collecting -> + ?line unlink(Target1), + ?line unlink(Target2), + ?line exit(Target1, bang), + ?line exit(Target2, bang), + ?line OkStatus; + {status, BadStatus} -> + ?line ?t:fail(BadStatus) + end. + process_status_exiting(Config) when is_list(Config) -> %% Make sure that erts_debug:get_internal_state({process_status,P}) %% returns exiting if it is in status P_EXITING. diff --git a/erts/epmd/src/epmd.c b/erts/epmd/src/epmd.c index c503c8c8cf..a1f202251c 100644 --- a/erts/epmd/src/epmd.c +++ b/erts/epmd/src/epmd.c @@ -497,8 +497,8 @@ static void dbg_gen_printf(int onsyslog,int perr,int from_level, (int) strlen(timestr)-1, timestr); len = strlen(buf); erts_vsnprintf(buf + len, DEBUG_BUFFER_SIZE - len, format, args); - if (perr == 1) - perror(buf); + if (perr != 0) + fprintf(stderr,"%s: %s\r\n",buf,strerror(perr)); else fprintf(stderr,"%s\r\n",buf); } @@ -509,7 +509,7 @@ void dbg_perror(EpmdVars *g,const char *format,...) { va_list args; va_start(args, format); - dbg_gen_printf(1,1,0,g,format,args); + dbg_gen_printf(1,errno,0,g,format,args); va_end(args); } diff --git a/erts/etc/common/heart.c b/erts/etc/common/heart.c index 778b3569c7..7a5746e630 100644 --- a/erts/etc/common/heart.c +++ b/erts/etc/common/heart.c @@ -727,16 +727,16 @@ static int heart_cmd_reply(int fd, char *s) { struct msg m; - int len = strlen(s) + 1; /* Include \0 */ + int len = strlen(s); /* if s >= MSG_BODY_SIZE, return a write * failure immediately. */ - if (len > sizeof(m.fill)) + if (len >= sizeof(m.fill)) return -1; m.op = HEART_CMD; - m.len = htons(len + 2); /* Include Op */ + m.len = htons(len + 1); /* Include Op */ strcpy((char*)m.fill, s); return write_message(fd, &m); diff --git a/erts/lib_src/common/erl_printf_format.c b/erts/lib_src/common/erl_printf_format.c index bd3d38e649..968d563325 100644 --- a/erts/lib_src/common/erl_printf_format.c +++ b/erts/lib_src/common/erl_printf_format.c @@ -1,7 +1,7 @@ /* * %CopyrightBegin% * - * Copyright Ericsson AB 2005-2009. All Rights Reserved. + * Copyright Ericsson AB 2005-2011. All Rights Reserved. * * The contents of this file are subject to the Erlang Public License, * Version 1.1, (the "License"); you may not use this file except in @@ -27,7 +27,7 @@ * length: hh | h | l | ll | L | j | t | b<sz> * conversion: d,i | o,u,x,X | e,E | f,F | g,G | a,A | c | s | T | * p | n | % - * sz: 8 | 16 | 32 | 64 | p + * sz: 8 | 16 | 32 | 64 | p | e */ /* Without this, variable argument lists break on VxWorks */ @@ -76,6 +76,18 @@ #endif #endif +#ifndef ERTS_SIZEOF_ETERM +# ifdef HALFWORD_HEAP_EMULATOR +# if SIZEOF_VOID_P == 8 +# define ERTS_SIZEOF_ETERM 4 +# else +# error "HALFWORD_HEAP_EMULATOR only allowed on 64-bit architecture" +# endif +# else +# define ERTS_SIZEOF_ETERM SIZEOF_VOID_P +# endif +#endif + #if defined(__GNUC__) # undef inline # define inline __inline__ @@ -520,6 +532,17 @@ int erts_printf_format(fmtfn_t fn, void* arg, char* fmt, va_list ap) #error No integer datatype with the same size as 'void *' found #endif } + else if (*ptr == 'e') { + ptr++; +#if SIZEOF_INT == ERTS_SIZEOF_ETERM +#elif SIZEOF_LONG == ERTS_SIZEOF_ETERM + fmt |= FMTL_l; +#elif SIZEOF_LONG_LONG == ERTS_SIZEOF_ETERM + fmt |= FMTL_ll; +#else +#error No integer datatype with the same size as Eterm found +#endif + } else { int bits = 0; while(isdigit((int) *ptr)) diff --git a/lib/common_test/src/ct_framework.erl b/lib/common_test/src/ct_framework.erl index 38a2aa53ac..3d4f674160 100644 --- a/lib/common_test/src/ct_framework.erl +++ b/lib/common_test/src/ct_framework.erl @@ -24,7 +24,7 @@ -module(ct_framework). --export([init_tc/3, end_tc/4, get_suite/2, report/2, warn/1]). +-export([init_tc/3, end_tc/3, end_tc/4, get_suite/2, report/2, warn/1]). -export([error_notification/4]). -export([overview_html_header/1]). @@ -434,6 +434,9 @@ try_set_default(Name,Key,Info,Where) -> %%% %%% @doc Test server framework callback, called by the test_server %%% when a test case is finished. +end_tc(Mod, Fun, Args) -> + %% Have to keep end_tc/3 for backwards compatabilty issues + end_tc(Mod, Fun, Args, '$end_tc_dummy'). end_tc(?MODULE,error_in_suite,_, _) -> % bad start! ok; end_tc(Mod,Func,{TCPid,Result,[Args]}, Return) when is_pid(TCPid) -> diff --git a/lib/compiler/src/beam_bsm.erl b/lib/compiler/src/beam_bsm.erl index 2a36fda1ea..5cc8252b99 100644 --- a/lib/compiler/src/beam_bsm.erl +++ b/lib/compiler/src/beam_bsm.erl @@ -651,10 +651,8 @@ add_warning(Term, Anno, Ws) -> warning_translate_label(Term, D) when is_tuple(Term) -> case element(1, Term) of {label,F} -> - case gb_trees:lookup(F, D) of - none -> Term; - {value,FA} -> setelement(1, Term, FA) - end; + FA = gb_trees:get(F, D), + setelement(1, Term, FA); _ -> Term end; warning_translate_label(Term, _) -> Term. diff --git a/lib/compiler/src/beam_dead.erl b/lib/compiler/src/beam_dead.erl index bb93110176..8e96569414 100644 --- a/lib/compiler/src/beam_dead.erl +++ b/lib/compiler/src/beam_dead.erl @@ -162,14 +162,11 @@ function({function,Name,Arity,CLabel,Is0}, Lc0) -> %% We must split the basic block when we encounter instructions with labels, %% such as catches and BIFs. All labels must be visible outside the blocks. -%% Also remove empty blocks. split_blocks({function,Name,Arity,CLabel,Is0}) -> Is = split_blocks(Is0, []), {function,Name,Arity,CLabel,Is}. -split_blocks([{block,[]}|Is], Acc) -> - split_blocks(Is, Acc); split_blocks([{block,Bl}|Is], Acc0) -> Acc = split_block(Bl, [], Acc0), split_blocks(Is, Acc); @@ -246,30 +243,24 @@ forward([{select_val,Reg,_,{list,List}}=I|Is], D0, Lc, Acc) -> D = update_value_dict(List, Reg, D0), forward(Is, D, Lc, [I|Acc]); forward([{label,Lbl}=LblI,{block,[{set,[Dst],[Lit],move}|BlkIs]}=Blk|Is], D, Lc, Acc) -> + %% Assumption: The target labels in a select_val/3 instruction + %% cannot be reached in any other way than through the select_val/3 + %% instruction (i.e. there can be no fallthrough to such label and + %% it cannot be referenced by, for example, a jump/1 instruction). Block = case gb_trees:lookup({Lbl,Dst}, D) of - {value,Lit} -> - %% The move instruction seems to be redundant, but also make - %% sure that the instruction preceeding the label - %% cannot fall through to the move instruction. - case is_unreachable_after(Acc) of - false -> Blk; %Must keep move instruction. - true -> {block,BlkIs} %Safe to remove move instruction. - end; - _ -> Blk %Keep move instruction. + {value,Lit} -> {block,BlkIs}; %Safe to remove move instruction. + _ -> Blk %Must keep move instruction. end, forward([Block|Is], D, Lc, [LblI|Acc]); forward([{label,Lbl}=LblI|[{move,Lit,Dst}|Is1]=Is0], D, Lc, Acc) -> + %% Assumption: The target labels in a select_val/3 instruction + %% cannot be reached in any other way than through the select_val/3 + %% instruction (i.e. there can be no fallthrough to such label and + %% it cannot be referenced by, for example, a jump/1 instruction). Is = case gb_trees:lookup({Lbl,Dst}, D) of - {value,Lit} -> - %% The move instruction seems to be redundant, but also make - %% sure that the instruction preceeding the label - %% cannot fall through to the move instruction. - case is_unreachable_after(Acc) of - false -> Is0; %Must keep move instruction. - true -> Is1 %Safe to remove move instruction. - end; - _ -> Is0 %Keep move instruction. - end, + {value,Lit} -> Is1; %Safe to remove move instruction. + _ -> Is0 %Keep move instruction. + end, forward(Is, D, Lc, [LblI|Acc]); forward([{test,is_eq_exact,_,[Dst,Src]}=I, {block,[{set,[Dst],[Src],move}|Bl]}|Is], D, Lc, Acc) -> @@ -299,16 +290,12 @@ update_value_dict([Lit,{f,Lbl}|T], Reg, D0) -> Key = {Lbl,Reg}, D = case gb_trees:lookup(Key, D0) of none -> gb_trees:insert(Key, Lit, D0); %New. - {value,Lit} -> D0; %Already correct. {value,inconsistent} -> D0; %Inconsistent. {value,_} -> gb_trees:update(Key, inconsistent, D0) end, update_value_dict(T, Reg, D); update_value_dict([], _, D) -> D. -is_unreachable_after([I|_]) -> - beam_jump:is_unreachable_after(I). - %%% %%% Scan instructions in reverse execution order and remove dead code. %%% @@ -602,16 +589,11 @@ count_bits_matched([{test,_,_,_}|Is], SavePoint, Bits) -> count_bits_matched([{bs_save2,Reg,SavePoint}|_], {Reg,SavePoint}, Bits) -> %% The save point we are looking for - we are done. Bits; -count_bits_matched([{bs_save2,_,_}|Is], SavePoint, Bits) -> - %% Another save point - keep counting. - count_bits_matched(Is, SavePoint, Bits); count_bits_matched([_|_], _, Bits) -> Bits. shortcut_bs_pos_used(To, Reg, D) -> shortcut_bs_pos_used_1(beam_utils:code_at(To, D), Reg, D). -shortcut_bs_pos_used_1([{bs_restore2,Reg,_}|_], Reg, _) -> - false; shortcut_bs_pos_used_1([{bs_context_to_binary,Reg}|_], Reg, _) -> false; shortcut_bs_pos_used_1(Is, Reg, D) -> diff --git a/lib/compiler/test/andor_SUITE.erl b/lib/compiler/test/andor_SUITE.erl index cab22e03d0..f7388f1614 100644 --- a/lib/compiler/test/andor_SUITE.erl +++ b/lib/compiler/test/andor_SUITE.erl @@ -28,7 +28,7 @@ suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> - test_lib:recompile(andor_SUITE), + test_lib:recompile(?MODULE), [t_case, t_and_or, t_andalso, t_orelse, inside, overlap, combined, in_case, before_and_inside_if]. diff --git a/lib/compiler/test/apply_SUITE.erl b/lib/compiler/test/apply_SUITE.erl index c517c4465e..25f8a8dfb5 100644 --- a/lib/compiler/test/apply_SUITE.erl +++ b/lib/compiler/test/apply_SUITE.erl @@ -28,7 +28,7 @@ suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> - test_lib:recompile(apply_SUITE), + test_lib:recompile(?MODULE), [mfa, fun_apply]. groups() -> diff --git a/lib/compiler/test/beam_validator_SUITE.erl b/lib/compiler/test/beam_validator_SUITE.erl index fc88ebeb41..556dc54a8f 100644 --- a/lib/compiler/test/beam_validator_SUITE.erl +++ b/lib/compiler/test/beam_validator_SUITE.erl @@ -46,7 +46,7 @@ end_per_testcase(Case, Config) when is_atom(Case), is_list(Config) -> suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> - test_lib:recompile(beam_validator_SUITE), + test_lib:recompile(?MODULE), [beam_files, compiler_bug, stupid_but_valid, xrange, yrange, stack, call_last, merge_undefined, uninit, unsafe_catch, dead_code, mult_labels, diff --git a/lib/compiler/test/bs_bincomp_SUITE.erl b/lib/compiler/test/bs_bincomp_SUITE.erl index 30c04f80cf..d39e340429 100644 --- a/lib/compiler/test/bs_bincomp_SUITE.erl +++ b/lib/compiler/test/bs_bincomp_SUITE.erl @@ -32,7 +32,7 @@ suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> - test_lib:recompile(bs_bincomp_SUITE), + test_lib:recompile(?MODULE), [byte_aligned, bit_aligned, extended_byte_aligned, extended_bit_aligned, mixed, filters, trim_coverage, nomatch, sizes, tail]. diff --git a/lib/compiler/test/bs_bit_binaries_SUITE.erl b/lib/compiler/test/bs_bit_binaries_SUITE.erl index 8be0c4196a..30276f1259 100644 --- a/lib/compiler/test/bs_bit_binaries_SUITE.erl +++ b/lib/compiler/test/bs_bit_binaries_SUITE.erl @@ -33,7 +33,7 @@ suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> - test_lib:recompile(bs_bit_binaries_SUITE), + test_lib:recompile(?MODULE), [misc, horrid_match, test_bitstr, test_bit_size, asymmetric_tests, big_asymmetric_tests, binary_to_and_from_list, big_binary_to_and_from_list, diff --git a/lib/compiler/test/bs_construct_SUITE.erl b/lib/compiler/test/bs_construct_SUITE.erl index c430b12b70..31c7890f26 100644 --- a/lib/compiler/test/bs_construct_SUITE.erl +++ b/lib/compiler/test/bs_construct_SUITE.erl @@ -35,7 +35,7 @@ suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> - test_lib:recompile(bs_construct_SUITE), + test_lib:recompile(?MODULE), [two, test1, fail, float_bin, in_guard, in_catch, nasty_literals, side_effect, opt, otp_7556, float_arith, otp_8054]. diff --git a/lib/compiler/test/bs_match_SUITE.erl b/lib/compiler/test/bs_match_SUITE.erl index 9184e14cb2..6a795f6634 100644 --- a/lib/compiler/test/bs_match_SUITE.erl +++ b/lib/compiler/test/bs_match_SUITE.erl @@ -35,7 +35,7 @@ match_string/1,zero_width/1,bad_size/1,haystack/1, cover_beam_bool/1]). --export([coverage_id/1]). +-export([coverage_id/1,coverage_external_ignore/2]). -include_lib("test_server/include/test_server.hrl"). @@ -43,7 +43,7 @@ suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> - test_lib:recompile(bs_match_SUITE), + test_lib:recompile(?MODULE), [fun_shadow, int_float, otp_5269, null_fields, wiger, bin_tail, save_restore, shadowed_size_var, partitioned_bs_match, function_clause, unit, @@ -585,13 +585,17 @@ coverage(Config) when is_list(Config) -> A+B end, 0, [a,b,c])), + ?line {<<42.0:64/float>>,float} = coverage_build(<<>>, <<42>>, float), ?line {<<>>,not_a_tuple} = coverage_build(<<>>, <<>>, not_a_tuple), ?line {<<16#76,"abc",16#A9,"abc">>,{x,42,43}} = coverage_build(<<>>, <<16#7,16#A>>, {x,y,z}), + ?line [<<2>>,<<1>>] = coverage_bc(<<1,2>>, []), + ?line {x,<<"abc">>,z} = coverage_setelement(<<2,"abc">>, {x,y,z}), ?line [42] = coverage_apply(<<42>>, [coverage_id]), + ?line 42 = coverage_external(<<42>>), ?line do_coverage_bin_to_term_list([]), ?line do_coverage_bin_to_term_list([lists:seq(0, 10),{a,b,c},<<23:42>>]), @@ -608,6 +612,10 @@ coverage_fold(Fun, Acc, <<H,T/binary>>) -> coverage_fold(Fun, Fun(IdFun(H), IdFun(Acc)), T); coverage_fold(Fun, Acc, <<>>) when is_function(Fun, 2) -> Acc. +coverage_build(Acc0, <<H,T/binary>>, float) -> + Float = id(<<H:64/float>>), + Acc = <<Acc0/binary,Float/binary>>, + coverage_build(Acc, T, float); coverage_build(Acc0, <<H,T/binary>>, Tuple0) -> Str = id(<<H:(id(4)),(H-1):4,"abc">>), Acc = id(<<Acc0/bitstring,Str/bitstring>>), @@ -618,6 +626,11 @@ coverage_build(Acc0, <<H,T/binary>>, Tuple0) -> end; coverage_build(Acc, <<>>, Tuple) -> {Acc,Tuple}. +coverage_bc(<<H,T/binary>>, Acc) -> + B = << <<C:8>> || C <- [H] >>, + coverage_bc(T, [B|Acc]); +coverage_bc(<<>>, Acc) -> Acc. + coverage_setelement(<<H,T1/binary>>, Tuple) when element(1, Tuple) =:= x -> setelement(H, Tuple, T1). @@ -625,6 +638,13 @@ coverage_apply(<<H,T/binary>>, [F|Fs]) -> [?MODULE:F(H)|coverage_apply(T, Fs)]; coverage_apply(<<>>, []) -> []. +coverage_external(<<H,T/binary>>) -> + ?MODULE:coverage_external_ignore(T, T), + H. + +coverage_external_ignore(_, _) -> + ok. + coverage_id(I) -> id(I). do_coverage_bin_to_term_list(L) -> diff --git a/lib/compiler/test/bs_utf_SUITE.erl b/lib/compiler/test/bs_utf_SUITE.erl index d37943ce3a..f30a4d3fef 100644 --- a/lib/compiler/test/bs_utf_SUITE.erl +++ b/lib/compiler/test/bs_utf_SUITE.erl @@ -30,7 +30,7 @@ suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> - test_lib:recompile(bs_utf_SUITE), + test_lib:recompile(?MODULE), [utf8_roundtrip, unused_utf_char, utf16_roundtrip, utf32_roundtrip, guard, extreme_tripping, literals, coverage]. diff --git a/lib/compiler/test/compilation_SUITE.erl b/lib/compiler/test/compilation_SUITE.erl index ba225b66d0..1343fbd1c9 100644 --- a/lib/compiler/test/compilation_SUITE.erl +++ b/lib/compiler/test/compilation_SUITE.erl @@ -27,7 +27,7 @@ suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> - test_lib:recompile(compilation_SUITE), + test_lib:recompile(?MODULE), [self_compile_old_inliner, self_compile, compiler_1, compiler_3, compiler_5, beam_compiler_1, beam_compiler_2, beam_compiler_3, beam_compiler_4, diff --git a/lib/compiler/test/compile_SUITE.erl b/lib/compiler/test/compile_SUITE.erl index 037c078fd0..b3e5376ffd 100644 --- a/lib/compiler/test/compile_SUITE.erl +++ b/lib/compiler/test/compile_SUITE.erl @@ -40,7 +40,7 @@ suite() -> [{ct_hooks,[ts_install_cth]}]. -spec all() -> all_return_type(). all() -> - test_lib:recompile(compile_SUITE), + test_lib:recompile(?MODULE), [app_test, file_1, module_mismatch, big_file, outdir, binary, makedep, cond_and_ifdef, listings, listings_big, other_output, package_forms, encrypted_abstr, diff --git a/lib/compiler/test/core_SUITE.erl b/lib/compiler/test/core_SUITE.erl index 21a5f65dee..26173c62b8 100644 --- a/lib/compiler/test/core_SUITE.erl +++ b/lib/compiler/test/core_SUITE.erl @@ -40,7 +40,7 @@ end_per_testcase(Case, Config) when is_atom(Case), is_list(Config) -> suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> - test_lib:recompile(core_SUITE), + test_lib:recompile(?MODULE), [dehydrated_itracer, nested_tries]. groups() -> diff --git a/lib/compiler/test/core_fold_SUITE.erl b/lib/compiler/test/core_fold_SUITE.erl index 710751b09d..ac14d36e82 100644 --- a/lib/compiler/test/core_fold_SUITE.erl +++ b/lib/compiler/test/core_fold_SUITE.erl @@ -30,7 +30,7 @@ suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> - test_lib:recompile(core_fold_SUITE), + test_lib:recompile(?MODULE), [t_element, setelement, t_length, append, t_apply, bifs, eq, nested_call_in_case, coverage]. diff --git a/lib/compiler/test/error_SUITE.erl b/lib/compiler/test/error_SUITE.erl index c9823665b4..6e0aadf007 100644 --- a/lib/compiler/test/error_SUITE.erl +++ b/lib/compiler/test/error_SUITE.erl @@ -27,7 +27,7 @@ suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> - test_lib:recompile(error_SUITE), + test_lib:recompile(?MODULE), [head_mismatch_line, warnings_as_errors, bif_clashes]. groups() -> diff --git a/lib/compiler/test/float_SUITE.erl b/lib/compiler/test/float_SUITE.erl index 6738265776..afc04fd440 100644 --- a/lib/compiler/test/float_SUITE.erl +++ b/lib/compiler/test/float_SUITE.erl @@ -26,7 +26,7 @@ suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> - test_lib:recompile(float_SUITE), + test_lib:recompile(?MODULE), [pending, bif_calls, math_functions, mixed_float_and_int]. diff --git a/lib/compiler/test/fun_SUITE.erl b/lib/compiler/test/fun_SUITE.erl index aa9be83c82..368a5815bf 100644 --- a/lib/compiler/test/fun_SUITE.erl +++ b/lib/compiler/test/fun_SUITE.erl @@ -27,7 +27,7 @@ suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> - test_lib:recompile(fun_SUITE), + test_lib:recompile(?MODULE), [test1, overwritten_fun, otp_7202, bif_fun]. groups() -> diff --git a/lib/compiler/test/guard_SUITE.erl b/lib/compiler/test/guard_SUITE.erl index 482564a32b..0e69efba6b 100644 --- a/lib/compiler/test/guard_SUITE.erl +++ b/lib/compiler/test/guard_SUITE.erl @@ -37,7 +37,7 @@ suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> - test_lib:recompile(guard_SUITE), + test_lib:recompile(?MODULE), [misc, const_cond, basic_not, complex_not, nested_nots, semicolon, complex_semicolon, comma, or_guard, more_or_guards, complex_or_guards, and_guard, xor_guard, diff --git a/lib/compiler/test/inline_SUITE.erl b/lib/compiler/test/inline_SUITE.erl index 7b9600c2f6..af2b8ec92a 100644 --- a/lib/compiler/test/inline_SUITE.erl +++ b/lib/compiler/test/inline_SUITE.erl @@ -31,7 +31,7 @@ suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> - test_lib:recompile(inline_SUITE), + test_lib:recompile(?MODULE), [attribute, bsdecode, bsdes, barnes2, decode1, smith, itracer, pseudoknot, lists, really_inlined, otp_7223, coverage]. diff --git a/lib/compiler/test/lc_SUITE.erl b/lib/compiler/test/lc_SUITE.erl index bcdcf2fd9f..c8908858ba 100644 --- a/lib/compiler/test/lc_SUITE.erl +++ b/lib/compiler/test/lc_SUITE.erl @@ -30,7 +30,7 @@ suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> - test_lib:recompile(lc_SUITE), + test_lib:recompile(?MODULE), [basic, deeply_nested, no_generator, empty_generator]. groups() -> diff --git a/lib/compiler/test/match_SUITE.erl b/lib/compiler/test/match_SUITE.erl index 04879300d1..9406d7de8f 100644 --- a/lib/compiler/test/match_SUITE.erl +++ b/lib/compiler/test/match_SUITE.erl @@ -22,16 +22,16 @@ init_per_group/2,end_per_group/2, pmatch/1,mixed/1,aliases/1,match_in_call/1, untuplify/1,shortcut_boolean/1,letify_guard/1, - selectify/1,underscore/1]). + selectify/1,underscore/1,coverage/1]). -include_lib("test_server/include/test_server.hrl"). suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> - test_lib:recompile(match_SUITE), + test_lib:recompile(?MODULE), [pmatch, mixed, aliases, match_in_call, untuplify, - shortcut_boolean, letify_guard, selectify, underscore]. + shortcut_boolean, letify_guard, selectify, underscore, coverage]. groups() -> []. @@ -398,4 +398,18 @@ underscore(Config) when is_list(Config) -> _ = is_list(Config), ok. +coverage(Config) when is_list(Config) -> + %% Cover beam_dead. + ok = coverage_1(x, a), + ok = coverage_1(x, b). + +coverage_1(B, Tag) -> + case Tag of + a -> coverage_2(1, a, B); + b -> coverage_2(2, b, B) + end. + +coverage_2(1, a, x) -> ok; +coverage_2(2, b, x) -> ok. + id(I) -> I. diff --git a/lib/compiler/test/misc_SUITE.erl b/lib/compiler/test/misc_SUITE.erl index f1f9b17084..c941a80e61 100644 --- a/lib/compiler/test/misc_SUITE.erl +++ b/lib/compiler/test/misc_SUITE.erl @@ -56,7 +56,7 @@ suite() -> [{ct_hooks,[ts_install_cth]}]. -spec all() -> misc_SUITE_test_cases(). all() -> - test_lib:recompile(misc_SUITE), + test_lib:recompile(?MODULE), [tobias, empty_string, md5, silly_coverage, confused_literals, integer_encoding, override_bif]. diff --git a/lib/compiler/test/num_bif_SUITE.erl b/lib/compiler/test/num_bif_SUITE.erl index 0a4750dc08..3479cf5425 100644 --- a/lib/compiler/test/num_bif_SUITE.erl +++ b/lib/compiler/test/num_bif_SUITE.erl @@ -40,7 +40,7 @@ suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> - test_lib:recompile(num_bif_SUITE), + test_lib:recompile(?MODULE), [t_abs, t_float, t_float_to_list, t_integer_to_list, {group, t_list_to_float}, t_list_to_integer, t_round, t_trunc]. diff --git a/lib/compiler/test/pmod_SUITE.erl b/lib/compiler/test/pmod_SUITE.erl index 4c68d777ca..9a317b5762 100644 --- a/lib/compiler/test/pmod_SUITE.erl +++ b/lib/compiler/test/pmod_SUITE.erl @@ -28,7 +28,7 @@ suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> - test_lib:recompile(pmod_SUITE), + test_lib:recompile(?MODULE), [basic, otp_8447]. groups() -> diff --git a/lib/compiler/test/receive_SUITE.erl b/lib/compiler/test/receive_SUITE.erl index 75e8045693..2a67615e5e 100644 --- a/lib/compiler/test/receive_SUITE.erl +++ b/lib/compiler/test/receive_SUITE.erl @@ -39,7 +39,7 @@ end_per_testcase(_Case, Config) -> suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> - test_lib:recompile(receive_SUITE), + test_lib:recompile(?MODULE), [recv, coverage, otp_7980, ref_opt, export]. groups() -> diff --git a/lib/compiler/test/record_SUITE.erl b/lib/compiler/test/record_SUITE.erl index 65b96590ed..363422ec7e 100644 --- a/lib/compiler/test/record_SUITE.erl +++ b/lib/compiler/test/record_SUITE.erl @@ -26,7 +26,8 @@ init_per_group/2,end_per_group/2, init_per_testcase/2,end_per_testcase/2, errors/1,record_test_2/1,record_test_3/1,record_access_in_guards/1, - guard_opt/1,eval_once/1,foobar/1,missing_test_heap/1, nested_access/1]). + guard_opt/1,eval_once/1,foobar/1,missing_test_heap/1, + nested_access/1,coverage/1]). init_per_testcase(_Case, Config) -> ?line Dog = test_server:timetrap(test_server:minutes(2)), @@ -40,10 +41,10 @@ end_per_testcase(_Case, Config) -> suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> - test_lib:recompile(record_SUITE), + test_lib:recompile(?MODULE), [errors, record_test_2, record_test_3, record_access_in_guards, guard_opt, eval_once, foobar, - missing_test_heap, nested_access]. + missing_test_heap, nested_access, coverage]. groups() -> []. @@ -568,4 +569,18 @@ nested_access(Config) when is_list(Config) -> ?line N2a = N2b, ok. +-record(rr, {a,b,c}). + +coverage(Config) when is_list(Config) -> + %% There should only remain one record test in the code below. + R0 = id(#rr{a=1,b=2,c=3}), + B = R0#rr.b, %Test the record here. + R = R0#rr{c=42}, %No need to test here. + if + B > R#rr.a -> %No need to test here. + ok + end, + #rr{a=1,b=2,c=42} = id(R), %Test for correctness. + ok. + id(I) -> I. diff --git a/lib/compiler/test/trycatch_SUITE.erl b/lib/compiler/test/trycatch_SUITE.erl index 92a79d3cba..c6e0f8d85d 100644 --- a/lib/compiler/test/trycatch_SUITE.erl +++ b/lib/compiler/test/trycatch_SUITE.erl @@ -31,7 +31,7 @@ suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> - test_lib:recompile(trycatch_SUITE), + test_lib:recompile(?MODULE), [basic, lean_throw, try_of, try_after, catch_oops, after_oops, eclectic, rethrow, nested_of, nested_catch, nested_after, nested_horrid, last_call_optimization, diff --git a/lib/compiler/test/warnings_SUITE.erl b/lib/compiler/test/warnings_SUITE.erl index dd18a6e1a3..f6a572abfa 100644 --- a/lib/compiler/test/warnings_SUITE.erl +++ b/lib/compiler/test/warnings_SUITE.erl @@ -54,7 +54,7 @@ end_per_testcase(_Case, Config) -> suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> - test_lib:recompile(warnings_SUITE), + test_lib:recompile(?MODULE), [pattern, pattern2, pattern3, pattern4, guard, bad_arith, bool_cases, bad_apply, files, effect, bin_opt_info, bin_construction]. diff --git a/lib/crypto/c_src/crypto.c b/lib/crypto/c_src/crypto.c index b8786f6f94..3ebf62d87c 100644 --- a/lib/crypto/c_src/crypto.c +++ b/lib/crypto/c_src/crypto.c @@ -134,7 +134,9 @@ static ERL_NIF_TERM des_ede3_cbc_crypt(ErlNifEnv* env, int argc, const ERL_NIF_T static ERL_NIF_TERM aes_cfb_128_crypt(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); static ERL_NIF_TERM aes_ctr_encrypt(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); static ERL_NIF_TERM rand_bytes_1(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM strong_rand_bytes_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); static ERL_NIF_TERM rand_bytes_3(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM strong_rand_mpint_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); static ERL_NIF_TERM rand_uniform_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); static ERL_NIF_TERM mod_exp_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); static ERL_NIF_TERM dss_verify(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); @@ -204,7 +206,9 @@ static ErlNifFunc nif_funcs[] = { {"aes_ctr_encrypt", 3, aes_ctr_encrypt}, {"aes_ctr_decrypt", 3, aes_ctr_encrypt}, {"rand_bytes", 1, rand_bytes_1}, + {"strong_rand_bytes_nif", 1, strong_rand_bytes_nif}, {"rand_bytes", 3, rand_bytes_3}, + {"strong_rand_mpint_nif", 3, strong_rand_mpint_nif}, {"rand_uniform_nif", 2, rand_uniform_nif}, {"mod_exp_nif", 3, mod_exp_nif}, {"dss_verify", 4, dss_verify}, @@ -704,6 +708,22 @@ static ERL_NIF_TERM rand_bytes_1(ErlNifEnv* env, int argc, const ERL_NIF_TERM ar ERL_VALGRIND_MAKE_MEM_DEFINED(data, bytes); return ret; } +static ERL_NIF_TERM strong_rand_bytes_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{/* (Bytes) */ + unsigned bytes; + unsigned char* data; + ERL_NIF_TERM ret; + if (!enif_get_uint(env, argv[0], &bytes)) { + return enif_make_badarg(env); + } + data = enif_make_new_binary(env, bytes, &ret); + if ( RAND_bytes(data, bytes) != 1) { + return atom_false; + } + ERL_VALGRIND_MAKE_MEM_DEFINED(data, bytes); + return ret; +} + static ERL_NIF_TERM rand_bytes_3(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) {/* (Bytes, TopMask, BottomMask) */ unsigned bytes; @@ -724,6 +744,47 @@ static ERL_NIF_TERM rand_bytes_3(ErlNifEnv* env, int argc, const ERL_NIF_TERM ar } return ret; } +static ERL_NIF_TERM strong_rand_mpint_nif(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{/* (Bytes, TopMask, BottomMask) */ + unsigned bits; + BIGNUM *bn_rand; + int top, bottom; + unsigned char* data; + unsigned dlen; + ERL_NIF_TERM ret; + if (!enif_get_uint(env, argv[0], &bits) + || !enif_get_int(env, argv[1], &top) + || !enif_get_int(env, argv[2], &bottom)) { + return enif_make_badarg(env); + } + if (! (top == -1 || top == 0 || top == 1) ) { + return enif_make_badarg(env); + } + if (! (bottom == 0 || bottom == 1) ) { + return enif_make_badarg(env); + } + + bn_rand = BN_new(); + if (! bn_rand ) { + return enif_make_badarg(env); + } + + /* Get a (bits) bit random number */ + if (!BN_rand(bn_rand, bits, top, bottom)) { + ret = atom_false; + } + else { + /* Copy the bignum into an erlang mpint binary. */ + dlen = BN_num_bytes(bn_rand); + data = enif_make_new_binary(env, dlen+4, &ret); + put_int32(data, dlen); + BN_bn2bin(bn_rand, data+4); + ERL_VALGRIND_MAKE_MEM_DEFINED(data+4, dlen); + } + BN_free(bn_rand); + + return ret; +} static int get_bn_from_mpint(ErlNifEnv* env, ERL_NIF_TERM term, BIGNUM** bnp) { diff --git a/lib/crypto/doc/src/crypto.xml b/lib/crypto/doc/src/crypto.xml index dfafe67348..1ccea6df79 100644 --- a/lib/crypto/doc/src/crypto.xml +++ b/lib/crypto/doc/src/crypto.xml @@ -4,7 +4,7 @@ <erlref> <header> <copyright> - <year>1999</year><year>2010</year> + <year>1999</year><year>2011</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -619,6 +619,21 @@ Mpint() = <![CDATA[<<ByteLen:32/integer-big, Bytes:ByteLen/binary>>]]> </desc> </func> <func> + <name>strong_rand_bytes(N) -> binary()</name> + <fsummary>Generate a binary of random bytes</fsummary> + <type> + <v>N = integer()</v> + </type> + <desc> + <p>Generates N bytes randomly uniform 0..255, and returns the + result in a binary. Uses a cryptographically secure prng seeded and + periodically mixed with operating system provided entropy. By default + this is the <c>RAND_bytes</c> method from OpenSSL.</p> + <p>May throw exception <c>low_entropy</c> in case the random generator + failed due to lack of secure "randomness".</p> + </desc> + </func> + <func> <name>rand_uniform(Lo, Hi) -> N</name> <fsummary>Generate a random number</fsummary> <type> @@ -633,6 +648,31 @@ Mpint() = <![CDATA[<<ByteLen:32/integer-big, Bytes:ByteLen/binary>>]]> </desc> </func> <func> + <name>strong_rand_mpint(N, Top, Bottom) -> Mpint</name> + <fsummary>Generate an N bit random number</fsummary> + <type> + <v>N = non_neg_integer()</v> + <v>Top = -1 | 0 | 1</v> + <v>Bottom = 0 | 1</v> + <v>Mpint = binary()</v> + </type> + <desc> + <p>Generate an N bit random number using OpenSSL's + cryptographically strong pseudo random number generator + <c>BN_rand</c>.</p> + <p>The parameter <c>Top</c> places constraints on the most + significant bits of the generated number. If <c>Top</c> is 1, then the + two most significant bits will be set to 1, if <c>Top</c> is 0, the + most significant bit will be 1, and if <c>Top</c> is -1 then no + constraints are applied and thus the generated number may be less than + N bits long.</p> + <p>If <c>Bottom</c> is 1, then the generated number is + constrained to be odd.</p> + <p>May throw exception <c>low_entropy</c> in case the random generator + failed due to lack of secure "randomness".</p> + </desc> + </func> + <func> <name>mod_exp(N, P, M) -> Result</name> <fsummary>Perform N ^ P mod M</fsummary> <type> diff --git a/lib/crypto/doc/src/notes.xml b/lib/crypto/doc/src/notes.xml index 5e9bda3920..ab1ffa9e5c 100644 --- a/lib/crypto/doc/src/notes.xml +++ b/lib/crypto/doc/src/notes.xml @@ -4,7 +4,7 @@ <chapter> <header> <copyright> - <year>1999</year><year>2010</year> + <year>1999</year><year>2011</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -30,6 +30,21 @@ </header> <p>This document describes the changes made to the Crypto application.</p> +<section><title>Crypto 2.0.2.2</title> + + <section><title>Improvements and New Features</title> + <list> + <item> + <p> + Strengthened random number generation. (Thanks to Geoff Cant)</p> + <p> + Own Id: OTP-9225</p> + </item> + </list> + </section> + +</section> + <section><title>Crypto 2.0.2.1</title> <section><title>Improvements and New Features</title> diff --git a/lib/crypto/src/crypto.erl b/lib/crypto/src/crypto.erl index d6e2e033c0..cc7b3acc9c 100644 --- a/lib/crypto/src/crypto.erl +++ b/lib/crypto/src/crypto.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1999-2010. All Rights Reserved. +%% Copyright Ericsson AB 1999-2011. All Rights Reserved. %% %% The contents of this file are subject to the Erlang Public License, %% Version 1.1, (the "License"); you may not use this file except in @@ -46,6 +46,7 @@ -export([rsa_private_encrypt/3, rsa_public_decrypt/3]). -export([dh_generate_key/1, dh_generate_key/2, dh_compute_key/3]). -export([rand_bytes/1, rand_bytes/3, rand_uniform/2]). +-export([strong_rand_bytes/1, strong_rand_mpint/3]). -export([mod_exp/3, mpint/1, erlint/1]). %% -export([idea_cbc_encrypt/3, idea_cbc_decrypt/3]). -export([aes_cbc_128_encrypt/3, aes_cbc_128_decrypt/3]). @@ -68,6 +69,8 @@ des_ede3_cbc_encrypt, des_ede3_cbc_decrypt, aes_cfb_128_encrypt, aes_cfb_128_decrypt, rand_bytes, + strong_rand_bytes, + strong_rand_mpint, rand_uniform, mod_exp, dss_verify,dss_sign, @@ -361,12 +364,32 @@ aes_cfb_128_crypt(_Key, _IVec, _Data, _IsEncrypt) -> ?nif_stub. %% RAND - pseudo random numbers using RN_ functions in crypto lib %% -spec rand_bytes(non_neg_integer()) -> binary(). +-spec strong_rand_bytes(non_neg_integer()) -> binary(). -spec rand_uniform(crypto_integer(), crypto_integer()) -> crypto_integer(). +-spec strong_rand_mpint(Bits::non_neg_integer(), + Top::-1..1, + Bottom::0..1) -> binary(). rand_bytes(_Bytes) -> ?nif_stub. + +strong_rand_bytes(Bytes) -> + case strong_rand_bytes_nif(Bytes) of + false -> erlang:error(low_entropy); + Bin -> Bin + end. +strong_rand_bytes_nif(_Bytes) -> ?nif_stub. + rand_bytes(_Bytes, _Topmask, _Bottommask) -> ?nif_stub. +strong_rand_mpint(Bits, Top, Bottom) -> + case strong_rand_mpint_nif(Bits,Top,Bottom) of + false -> erlang:error(low_entropy); + Bin -> Bin + end. +strong_rand_mpint_nif(_Bits, _Top, _Bottom) -> ?nif_stub. + + rand_uniform(From,To) when is_binary(From), is_binary(To) -> case rand_uniform_nif(From,To) of <<Len:32/integer, MSB, Rest/binary>> when MSB > 127 -> diff --git a/lib/crypto/test/crypto_SUITE.erl b/lib/crypto/test/crypto_SUITE.erl index fe8f8e69a0..854a8b4485 100644 --- a/lib/crypto/test/crypto_SUITE.erl +++ b/lib/crypto/test/crypto_SUITE.erl @@ -46,6 +46,7 @@ aes_ctr/1, mod_exp_test/1, rand_uniform_test/1, + strong_rand_test/1, rsa_verify_test/1, dsa_verify_test/1, rsa_sign_test/1, @@ -68,7 +69,8 @@ all() -> md5_mac_io, sha, sha_update, %% sha256, sha256_update, sha512,sha512_update, des_cbc, aes_cfb, aes_cbc, - aes_cbc_iter, aes_ctr, des_cbc_iter, des_ecb, rand_uniform_test, + aes_cbc_iter, aes_ctr, des_cbc_iter, des_ecb, + rand_uniform_test, strong_rand_test, rsa_verify_test, dsa_verify_test, rsa_sign_test, dsa_sign_test, rsa_encrypt_decrypt, dh, exor_test, rc4_test, rc4_stream_test, mod_exp_test, blowfish_cfb64, @@ -710,6 +712,33 @@ rand_uniform_aux_test(N) -> %% %% +strong_rand_test(doc) -> + "strong_rand_mpint and strong_random_bytes testing"; +strong_rand_test(suite) -> + []; +strong_rand_test(Config) when is_list(Config) -> + strong_rand_aux_test(180), + ?line 10 = byte_size(crypto:strong_rand_bytes(10)). + +strong_rand_aux_test(0) -> + ?line t(crypto:strong_rand_mpint(0,0,0) =:= <<0,0,0,0>>), + ok; +strong_rand_aux_test(1) -> + ?line t(crypto:erlint(crypto:strong_rand_mpint(1,0,1)) =:= 1), + ?line strong_rand_aux_test(0); +strong_rand_aux_test(N) -> + ?line t(sru_length(crypto:strong_rand_mpint(N,-1,0)) =< N), + ?line t(sru_length(crypto:strong_rand_mpint(N,0,0)) =:= N), + ?line t(crypto:erlint(crypto:strong_rand_mpint(N,0,1)) band 1 =:= 1), + ?line t(crypto:erlint(crypto:strong_rand_mpint(N,1,0)) bsr (N - 2) =:= 2#11), + ?line strong_rand_aux_test(N-1). + +sru_length(Mpint) -> + I = crypto:erlint(Mpint), + length(erlang:integer_to_list(I, 2)). + +%% +%% %% %% rsa_verify_test(doc) -> @@ -1097,7 +1126,7 @@ worker_loop(0, _) -> ok; worker_loop(N, Config) -> Funcs = { md5, md5_update, md5_mac, md5_mac_io, sha, sha_update, des_cbc, - aes_cfb, aes_cbc, des_cbc_iter, rand_uniform_test, + aes_cfb, aes_cbc, des_cbc_iter, rand_uniform_test, strong_rand_test, rsa_verify_test, exor_test, rc4_test, rc4_stream_test, mod_exp_test }, F = element(random:uniform(size(Funcs)),Funcs), diff --git a/lib/crypto/vsn.mk b/lib/crypto/vsn.mk index e2d6fd0b37..740c68d8fa 100644 --- a/lib/crypto/vsn.mk +++ b/lib/crypto/vsn.mk @@ -1 +1 @@ -CRYPTO_VSN = 2.0.2.1 +CRYPTO_VSN = 2.0.2.2 diff --git a/lib/dialyzer/doc/manual.txt b/lib/dialyzer/doc/manual.txt index 1d7a1a6222..d519ac960b 100644 --- a/lib/dialyzer/doc/manual.txt +++ b/lib/dialyzer/doc/manual.txt @@ -37,7 +37,7 @@ The parameters are: The analysis starts from .beam bytecode files. The files must be compiled with +debug_info. - Source code: - The analysis starts from .erl files. + The analysis starts from .erl files. Controlling the discrepancies reported by the Dialyzer ====================================================== @@ -131,7 +131,7 @@ Usage: dialyzer [--help] [--version] [--shell] [--quiet] [--verbose] [--check_plt] [--no_check_plt] [--plt_info] [--get_warnings] [--no_native] [--fullpath] -Options: +Options: files_or_dirs (for backwards compatibility also as: -c files_or_dirs) Use Dialyzer from the command line to detect defects in the specified files or directories containing .erl or .beam files, @@ -169,7 +169,7 @@ Options: --output_plt file Store the plt at the specified file after building it. --plt plt - Use the specified plt as the initial plt (if the plt was built + Use the specified plt as the initial plt (if the plt was built during setup the files will be checked for consistency). --plts plt* Merge the specified plts to create the initial plt -- requires @@ -204,8 +204,8 @@ Options: --add_to_plt The plt is extended to also include the files specified with -c and -r. Use --plt to specify which plt to start from, and --output_plt to - specify where to put the plt. Note that the analysis might include - files from the plt if they depend on the new files. + specify where to put the plt. Note that the analysis might include + files from the plt if they depend on the new files. This option only works with beam files. --remove_from_plt The information from the files specified with -c and -r is removed @@ -269,13 +269,13 @@ Warning options: Include warnings about behaviour callbacks which drift from the published recommended interfaces. -Wunderspecs *** - Warn about underspecified functions + Warn about underspecified functions (those whose -spec is strictly more allowing than the success typing). The following options are also available but their use is not recommended: (they are mostly for Dialyzer developers and internal debugging) -Woverspecs *** - Warn about overspecified functions + Warn about overspecified functions (those whose -spec is strictly less allowing than the success typing). -Wspecdiffs *** Warn when the -spec is different than the success typing. @@ -306,8 +306,8 @@ dialyzer:run(OptList) -> Warnings Warnings :: [{tag(), id(), msg()}] tag() :: 'warn_return_no_exit' | 'warn_return_only_exit' | 'warn_not_called' | 'warn_non_proper_list' | 'warn_fun_app' | 'warn_matching' - | 'warn_failing_call' | 'warn_contract_types' - | 'warn_contract_syntax' | 'warn_contract_not_equal' + | 'warn_failing_call' | 'warn_contract_types' + | 'warn_contract_syntax' | 'warn_contract_not_equal' | 'warn_contract_subtype' | 'warn_contract_supertype' id() :: {File :: string(), Line :: integer()} msg() :: Undefined @@ -319,24 +319,31 @@ Option :: {files, [Filename :: string()]} | {from, src_code | byte_code} %% Defaults to byte_code | {init_plt, FileName :: string()} %% If changed from default | {plts, [FileName :: string()]} %% If changed from default - | {include_dirs, [DirName :: string()]} + | {include_dirs, [DirName :: string()]} | {output_file, FileName :: string()} | {output_plt, FileName :: string()} | {analysis_type, 'succ_typings' | 'plt_add' | 'plt_build' | 'plt_check' | 'plt_remove'} | {warnings, [WarnOpts]} + | {get_warnings, bool()} WarnOpts :: no_return | no_unused | no_improper_lists | no_fun_app | no_match + | no_opaque | no_fail_call - | unmatched_returns | error_handling + | race_conditions + | behaviours + | unmatched_returns + | overspecs + | underspecs + | specdiffs dialyzer:format_warning({tag(), id(), msg()}) -> string() - + Returns a string representation of the warnings as returned by dialyzer:run/1. dialyzer:plt_info(string()) -> {'ok', [{atom(), any()}]} | {'error', atom()} @@ -392,7 +399,7 @@ files that depend on these files. Note that this consistency check will be performed automatically the next time you run Dialyzer with this plt. The --check_plt option is merely for doing so without doing any other analysis. - + ----------------------------------------------- -- -- Feedback & bug reports diff --git a/lib/dialyzer/doc/src/dialyzer.xml b/lib/dialyzer/doc/src/dialyzer.xml index b6547b11e1..4080dfdf77 100644 --- a/lib/dialyzer/doc/src/dialyzer.xml +++ b/lib/dialyzer/doc/src/dialyzer.xml @@ -241,7 +241,7 @@ <item>Include warnings about behaviour callbacks which drift from the published recommended interfaces.</item> <tag><c><![CDATA[-Wunderspecs]]></c>***</tag> - <item>Warn about underspecified functions + <item>Warn about underspecified functions (the -spec is strictly more allowing than the success typing).</item> </taglist> <p>The following options are also available but their use is not @@ -249,7 +249,7 @@ debugging)</p> <taglist> <tag><c><![CDATA[-Woverspecs]]></c>***</tag> - <item>Warn about overspecified functions + <item>Warn about overspecified functions (the -spec is strictly less allowing than the success typing).</item> <tag><c><![CDATA[-Wspecdiffs]]></c>***</tag> <item>Warn when the -spec is different than the success typing.</item> @@ -278,34 +278,34 @@ <desc> <p>Dialyzer GUI version.</p> <code type="none"><![CDATA[ -OptList : [Option] -Option : {files, [Filename : string()]} - | {files_rec, [DirName : string()]} - | {defines, [{Macro: atom(), Value : term()}]} - | {from, src_code | byte_code} %% Defaults to byte_code - | {init_plt, FileName : string()} %% If changed from default - | {plts, [FileName :: string()]} %% If changed from default - | {include_dirs, [DirName : string()]} - | {output_file, FileName : string()} - | {output_plt, FileName :: string()} - | {analysis_type, 'succ_typings' | 'plt_add' | 'plt_build' | 'plt_check' | 'plt_remove'} - | {warnings, [WarnOpts]} - | {get_warnings, bool()} +OptList :: [Option] +Option :: {files, [Filename :: string()]} + | {files_rec, [DirName :: string()]} + | {defines, [{Macro: atom(), Value : term()}]} + | {from, src_code | byte_code} %% Defaults to byte_code + | {init_plt, FileName :: string()} %% If changed from default + | {plts, [FileName :: string()]} %% If changed from default + | {include_dirs, [DirName :: string()]} + | {output_file, FileName :: string()} + | {output_plt, FileName :: string()} + | {analysis_type, 'succ_typings' | 'plt_add' | 'plt_build' | 'plt_check' | 'plt_remove'} + | {warnings, [WarnOpts]} + | {get_warnings, bool()} -WarnOpts : no_return - | no_unused - | no_improper_lists - | no_fun_app - | no_match - | no_opaque - | no_fail_call - | error_handling - | race_conditions - | behaviours - | unmatched_returns - | overspecs - | underspecs - | specdiffs +WarnOpts :: no_return + | no_unused + | no_improper_lists + | no_fun_app + | no_match + | no_opaque + | no_fail_call + | error_handling + | race_conditions + | behaviours + | unmatched_returns + | overspecs + | underspecs + | specdiffs ]]></code> </desc> </func> @@ -320,12 +320,12 @@ WarnOpts : no_return <p>Dialyzer command line version.</p> <code type="none"><![CDATA[ Warnings :: [{Tag, Id, Msg}] -Tag : 'warn_return_no_exit' | 'warn_return_only_exit' - | 'warn_not_called' | 'warn_non_proper_list' - | 'warn_fun_app' | 'warn_matching' - | 'warn_failing_call' | 'warn_contract_types' - | 'warn_contract_syntax' | 'warn_contract_not_equal' - | 'warn_contract_subtype' | 'warn_contract_supertype' +Tag :: 'warn_return_no_exit' | 'warn_return_only_exit' + | 'warn_not_called' | 'warn_non_proper_list' + | 'warn_fun_app' | 'warn_matching' + | 'warn_failing_call' | 'warn_contract_types' + | 'warn_contract_syntax' | 'warn_contract_not_equal' + | 'warn_contract_subtype' | 'warn_contract_supertype' Id = {File :: string(), Line :: integer()} Msg = msg() -- Undefined ]]></code> diff --git a/lib/kernel/test/heart_SUITE.erl b/lib/kernel/test/heart_SUITE.erl index 043c753cf8..233e438dc9 100644 --- a/lib/kernel/test/heart_SUITE.erl +++ b/lib/kernel/test/heart_SUITE.erl @@ -22,7 +22,7 @@ -export([all/0, suite/0,groups/0,init_per_suite/1, end_per_suite/1, init_per_group/2,end_per_group/2, start/1, restart/1, - reboot/1, set_cmd/1, clear_cmd/1, + reboot/1, set_cmd/1, clear_cmd/1, get_cmd/1, dont_drop/1, kill_pid/1]). -export([init_per_testcase/2, end_per_testcase/2]). @@ -58,7 +58,7 @@ end_per_testcase(_Func, Config) -> suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> - [start, restart, reboot, set_cmd, clear_cmd, kill_pid]. + [start, restart, reboot, set_cmd, clear_cmd, get_cmd, kill_pid]. groups() -> []. @@ -246,6 +246,15 @@ clear_cmd(Config) when is_list(Config) -> end, ok. +get_cmd(suite) -> []; +get_cmd(Config) when is_list(Config) -> + ?line {ok, Node} = start_check(slave, heart_test), + Cmd = "test", + ?line ok = rpc:call(Node, heart, set_cmd, [Cmd]), + ?line {ok, Cmd} = rpc:call(Node, heart, get_cmd, []), + stop_node(Node), + ok. + dont_drop(suite) -> %%% Removed as it may crash epmd/distribution in colourful %%% ways. While we ARE finding out WHY, it would diff --git a/lib/public_key/src/public_key.appup.src b/lib/public_key/src/public_key.appup.src index c65ac7bc99..4986801dad 100644 --- a/lib/public_key/src/public_key.appup.src +++ b/lib/public_key/src/public_key.appup.src @@ -1,6 +1,16 @@ %% -*- erlang -*- {"%VSN%", [ + {"0.11", + [ + {update, public_key, soft, soft_purge, soft_purge, []}, + {update, pubkey_pem, soft, soft_purge, soft_purge, []}, + {add_module, pubkey_ssh, soft, soft_purge, soft_purge}, + {update, pubkey_cert, soft, soft_purge, soft_purge, []}, + {update, pubkey_cert_records, soft, soft_purge, soft_purge, []} + ] + }, + {"0.10", [ {update, public_key, soft, soft_purge, soft_purge, []}, @@ -25,6 +35,16 @@ } ], [ + {"0.11", + [ + {update, public_key, soft, soft_purge, soft_purge, []}, + {update, pubkey_pem, soft, soft_purge, soft_purge, []}, + {delete_module, pubkey_ssh, soft, soft_purge, soft_purge}, + {update, pubkey_cert, soft, soft_purge, soft_purge, []}, + {update, pubkey_cert_records, soft, soft_purge, soft_purge, []} + ] + }, + {"0.10", [ {update, public_key, soft, soft_purge, soft_purge, []}, diff --git a/lib/public_key/test/pkits_SUITE.erl b/lib/public_key/test/pkits_SUITE.erl index 660af4e8ab..a325a975e9 100644 --- a/lib/public_key/test/pkits_SUITE.erl +++ b/lib/public_key/test/pkits_SUITE.erl @@ -26,7 +26,6 @@ -compile(export_all). -include_lib("public_key/include/public_key.hrl"). -%%-include("public_key.hrl"). -define(error(Format,Args), error(Format,Args,?FILE,?LINE)). -define(warning(Format,Args), warning(Format,Args,?FILE,?LINE)). @@ -42,18 +41,65 @@ -define(NIST5, "2.16.840.1.101.3.2.1.48.5"). -define(NIST6, "2.16.840.1.101.3.2.1.48.6"). +-record(verify_state, { + certs_db, + crl_info, + revoke_state}). %% -suite() -> [{ct_hooks,[ts_install_cth]}]. +suite() -> + [{ct_hooks,[ts_install_cth]}]. all() -> - [signature_verification, validity_periods, - verifying_name_chaining, - verifying_paths_with_self_issued_certificates, - verifying_basic_constraints, key_usage, - name_constraints, private_certificate_extensions]. + [{group, signature_verification}, + {group, validity_periods}, + {group, verifying_name_chaining}, + {group, verifying_paths_with_self_issued_certificates}, + %%{group, basic_certificate_revocation_tests}, + %%{group, delta_crls}, + %%{group, distribution_points}, + {group, verifying_basic_constraints}, + {group, key_usage}, + {group, name_constraints}, + {group, private_certificate_extensions}]. groups() -> - []. + [{signature_verification, [], [valid_rsa_signature, + invalid_rsa_signature, valid_dsa_signature, + invalid_dsa_signature]}, + {validity_periods, [], + [not_before_invalid, not_before_valid, not_after_invalid, not_after_valid]}, + {verifying_name_chaining, [], + [invalid_name_chain, whitespace_name_chain, capitalization_name_chain, + uid_name_chain, attrib_name_chain, string_name_chain]}, + {verifying_paths_with_self_issued_certificates, [], + [basic_valid, basic_invalid, crl_signing_valid, crl_signing_invalid]}, + %% {basic_certificate_revocation_tests, [], + %% [missing_CRL, revoked_CA, revoked_peer, invalid_CRL_signature, + %% invalid_CRL_issuer, invalid_CRL, valid_CRL, + %% unknown_CRL_extension, old_CRL, fresh_CRL, valid_serial, + %% invalid_serial, valid_seperate_keys, invalid_separate_keys]}, + %% {delta_crls, [], [delta_without_crl, valid_delta_crls, invalid_delta_crls]}, + %% {distribution_points, [], [valid_distribution_points, + %% valid_distribution_points_no_issuing_distribution_point, + %% invalid_distribution_points, valid_only_contains, + %% invalid_only_contains, valid_only_some_reasons, + %% invalid_only_some_reasons, valid_indirect_crl, + %% invalid_indirect_crl, valid_crl_issuer, invalid_crl_issuer]}, + {verifying_basic_constraints,[], + [missing_basic_constraints, valid_basic_constraint, invalid_path_constraints, + valid_path_constraints]}, + {key_usage, [], + [invalid_key_usage, valid_key_usage]}, + {name_constraints, [], + [valid_DN_name_constraints, invalid_DN_name_constraints, + valid_rfc822_name_constraints, + invalid_rfc822_name_constraints, valid_DN_and_rfc822_name_constraints, + invalid_DN_and_rfc822_name_constraints, valid_dns_name_constraints, + invalid_dns_name_constraints, valid_uri_name_constraints, + invalid_uri_name_constraints]}, + {private_certificate_extensions, [], + [unknown_critical_extension, unknown_not_critical_extension]} + ]. init_per_group(_GroupName, Config) -> Config. @@ -61,112 +107,706 @@ init_per_group(_GroupName, Config) -> end_per_group(_GroupName, Config) -> Config. +init_per_testcase(_Func, Config) -> + Datadir = proplists:get_value(data_dir, Config), + put(datadir, Datadir), + Config. + +end_per_testcase(_Func, Config) -> + Config. + +init_per_suite(Config) -> + {skip, "PKIX Conformance test certificates expired 14 of April 2011," + " new conformance test suite uses new format so skip until PKCS-12 support is implemented"}. + %% try crypto:start() of + %% ok -> + %% Config + %% catch _:_ -> + %% {skip, "Crypto did not start"} + %% end. + +end_per_suite(_Config) -> + application:stop(crypto). + +%%----------------------------------------------------------------------------- +valid_rsa_signature(doc) -> + ["Test rsa signatur verification"]; +valid_rsa_signature(suite) -> + []; +valid_rsa_signature(Config) when is_list(Config) -> + run([{ "4.1.1", "Valid Signatures Test1", ok}]). + +invalid_rsa_signature(doc) -> + ["Test rsa signatur verification"]; +invalid_rsa_signature(suite) -> + []; +invalid_rsa_signature(Config) when is_list(Config) -> + run([{ "4.1.2", "Invalid CA Signature Test2", {bad_cert,invalid_signature}}, + { "4.1.3", "Invalid EE Signature Test3", {bad_cert,invalid_signature}}]). + +valid_dsa_signature(doc) -> + ["Test dsa signatur verification"]; +valid_dsa_signature(suite) -> + []; +valid_dsa_signature(Config) when is_list(Config) -> + run([{ "4.1.4", "Valid DSA Signatures Test4", ok}, + { "4.1.5", "Valid DSA Parameter Inheritance Test5", ok}]). + +invalid_dsa_signature(doc) -> + ["Test dsa signatur verification"]; +invalid_dsa_signature(suite) -> + []; +invalid_dsa_signature(Config) when is_list(Config) -> + run([{ "4.1.6", "Invalid DSA Signature Test6",{bad_cert,invalid_signature}}]). +%%----------------------------------------------------------------------------- +not_before_invalid(doc) -> + [""]; +not_before_invalid(suite) -> + []; +not_before_invalid(Config) when is_list(Config) -> + run([{ "4.2.1", "Invalid CA notBefore Date Test1",{bad_cert, cert_expired}}, + { "4.2.2", "Invalid EE notBefore Date Test2",{bad_cert, cert_expired}}]). + +not_before_valid(doc) -> + [""]; +not_before_valid(suite) -> + []; +not_before_valid(Config) when is_list(Config) -> + run([{ "4.2.3", "Valid pre2000 UTC notBefore Date Test3", ok}, + { "4.2.4", "Valid GeneralizedTime notBefore Date Test4", ok}]). + +not_after_invalid(doc) -> + [""]; +not_after_invalid(suite) -> + []; +not_after_invalid(Config) when is_list(Config) -> + run([{ "4.2.5", "Invalid CA notAfter Date Test5", {bad_cert, cert_expired}}, + { "4.2.6", "Invalid EE notAfter Date Test6", {bad_cert, cert_expired}}, + { "4.2.7", "Invalid pre2000 UTC EE notAfter Date Test7",{bad_cert, cert_expired}}]). + +not_after_valid(doc) -> + [""]; +not_after_valid(suite) -> + []; +not_after_valid(Config) when is_list(Config) -> + run([{ "4.2.8", "Valid GeneralizedTime notAfter Date Test8", ok}]). +%%----------------------------------------------------------------------------- +invalid_name_chain(doc) -> + [""]; +invalid_name_chain(suite) -> + []; +invalid_name_chain(Config) when is_list(Config) -> + run([{ "4.3.1", "Invalid Name Chaining EE Test1", {bad_cert, invalid_issuer}}, + { "4.3.2", "Invalid Name Chaining Order Test2", {bad_cert, invalid_issuer}}]). + +whitespace_name_chain(doc) -> + [""]; +whitespace_name_chain(suite) -> + []; +whitespace_name_chain(Config) when is_list(Config) -> + run([{ "4.3.3", "Valid Name Chaining Whitespace Test3", ok}, + { "4.3.4", "Valid Name Chaining Whitespace Test4", ok}]). + +capitalization_name_chain(doc) -> + [""]; +capitalization_name_chain(suite) -> + []; +capitalization_name_chain(Config) when is_list(Config) -> + run([{ "4.3.5", "Valid Name Chaining Capitalization Test5",ok}]). + +uid_name_chain(doc) -> + [""]; +uid_name_chain(suite) -> + []; +uid_name_chain(Config) when is_list(Config) -> + run([{ "4.3.6", "Valid Name Chaining UIDs Test6",ok}]). + +attrib_name_chain(doc) -> + [""]; +attrib_name_chain(suite) -> + []; +attrib_name_chain(Config) when is_list(Config) -> + run([{ "4.3.7", "Valid RFC3280 Mandatory Attribute Types Test7", ok}, + { "4.3.8", "Valid RFC3280 Optional Attribute Types Test8", ok}]). + +string_name_chain(doc) -> + [""]; +string_name_chain(suite) -> + []; +string_name_chain(Config) when is_list(Config) -> + run([{ "4.3.9", "Valid UTF8String Encoded Names Test9", ok}, + { "4.3.10", "Valid Rollover from PrintableString to UTF8String Test10", ok}, + { "4.3.11", "Valid UTF8String Case Insensitive Match Test11", ok}]). + +%%----------------------------------------------------------------------------- + +basic_valid(doc) -> + [""]; +basic_valid(suite) -> + []; +basic_valid(Config) when is_list(Config) -> + run([{ "4.5.1", "Valid Basic Self-Issued Old With New Test1", ok}, + { "4.5.3", "Valid Basic Self-Issued New With Old Test3", ok}, + { "4.5.4", "Valid Basic Self-Issued New With Old Test4", ok} + ]). + +basic_invalid(doc) -> + [""]; +basic_invalid(suite) -> + []; +basic_invalid(Config) when is_list(Config) -> + run([{"4.5.2", "Invalid Basic Self-Issued Old With New Test2", + {bad_cert, {revoked, keyCompromise}}}, + {"4.5.5", "Invalid Basic Self-Issued New With Old Test5", + {bad_cert, {revoked, keyCompromise}}} + ]). + +crl_signing_valid(doc) -> + [""]; +crl_signing_valid(suite) -> + []; +crl_signing_valid(Config) when is_list(Config) -> + run([{ "4.5.6", "Valid Basic Self-Issued CRL Signing Key Test6", ok}]). + +crl_signing_invalid(doc) -> + [""]; +crl_signing_invalid(suite) -> + []; +crl_signing_invalid(Config) when is_list(Config) -> + run([{ "4.5.7", "Invalid Basic Self-Issued CRL Signing Key Test7", + {bad_cert, {revoked, keyCompromise}}}, + { "4.5.8", "Invalid Basic Self-Issued CRL Signing Key Test8", + {bad_cert, invalid_key_usage}} + ]). + +%%----------------------------------------------------------------------------- +missing_CRL(doc) -> + [""]; +missing_CRL(suite) -> + []; +missing_CRL(Config) when is_list(Config) -> + run([{ "4.4.1", "Missing CRL Test1",{bad_cert, + revocation_status_undetermined}}]). + +revoked_CA(doc) -> + [""]; +revoked_CA(suite) -> + []; +revoked_CA(Config) when is_list(Config) -> + run([{ "4.4.2", "Invalid Revoked CA Test2", {bad_cert, + {revoked, keyCompromise}}}]). + +revoked_peer(doc) -> + [""]; +revoked_peer(suite) -> + []; +revoked_peer(Config) when is_list(Config) -> + run([{ "4.4.3", "Invalid Revoked EE Test3", {bad_cert, + {revoked, keyCompromise}}}]). + +invalid_CRL_signature(doc) -> + [""]; +invalid_CRL_signature(suite) -> + []; +invalid_CRL_signature(Config) when is_list(Config) -> + run([{ "4.4.4", "Invalid Bad CRL Signature Test4", + {bad_cert, revocation_status_undetermined}}]). + +invalid_CRL_issuer(doc) -> + [""]; +invalid_CRL_issuer(suite) -> + []; +invalid_CRL_issuer(Config) when is_list(Config) -> + run({ "4.4.5", "Invalid Bad CRL Issuer Name Test5", + {bad_cert, revocation_status_undetermined}}). + +invalid_CRL(doc) -> + [""]; +invalid_CRL(suite) -> + []; +invalid_CRL(Config) when is_list(Config) -> + run([{ "4.4.6", "Invalid Wrong CRL Test6", + {bad_cert, revocation_status_undetermined}}]). + +valid_CRL(doc) -> + [""]; +valid_CRL(suite) -> + []; +valid_CRL(Config) when is_list(Config) -> + run([{ "4.4.7", "Valid Two CRLs Test7", ok}]). + +unknown_CRL_extension(doc) -> + [""]; +unknown_CRL_extension(suite) -> + []; +unknown_CRL_extension(Config) when is_list(Config) -> + run([{ "4.4.8", "Invalid Unknown CRL Entry Extension Test8", + {bad_cert, {revoked, keyCompromise}}}, + { "4.4.9", "Invalid Unknown CRL Extension Test9", + {bad_cert, {revoked, keyCompromise}}}, + { "4.4.10", "Invalid Unknown CRL Extension Test10", + {bad_cert, revocation_status_undetermined}}]). + +old_CRL(doc) -> + [""]; +old_CRL(suite) -> + []; +old_CRL(Config) when is_list(Config) -> + run([{ "4.4.11", "Invalid Old CRL nextUpdate Test11", + {bad_cert, revocation_status_undetermined}}, + { "4.4.12", "Invalid pre2000 CRL nextUpdate Test12", + {bad_cert, revocation_status_undetermined}}]). + +fresh_CRL(doc) -> + [""]; +fresh_CRL(suite) -> + []; +fresh_CRL(Config) when is_list(Config) -> + run([{ "4.4.13", "Valid GeneralizedTime CRL nextUpdate Test13", ok}]). + +valid_serial(doc) -> + [""]; +valid_serial(suite) -> + []; +valid_serial(Config) when is_list(Config) -> + run([ + { "4.4.14", "Valid Negative Serial Number Test14",ok}, + { "4.4.16", "Valid Long Serial Number Test16", ok}, + { "4.4.17", "Valid Long Serial Number Test17", ok} + ]). + +invalid_serial(doc) -> + [""]; +invalid_serial(suite) -> + []; +invalid_serial(Config) when is_list(Config) -> + run([{ "4.4.15", "Invalid Negative Serial Number Test15", + {bad_cert, {revoked, keyCompromise}}}, + { "4.4.18", "Invalid Long Serial Number Test18", + {bad_cert, {revoked, keyCompromise}}}]). + +valid_seperate_keys(doc) -> + [""]; +valid_seperate_keys(suite) -> + []; +valid_seperate_keys(Config) when is_list(Config) -> + run([{ "4.4.19", "Valid Separate Certificate and CRL Keys Test19", ok}]). + +invalid_separate_keys(doc) -> + [""]; +invalid_separate_keys(suite) -> + []; +invalid_separate_keys(Config) when is_list(Config) -> + run([{ "4.4.20", "Invalid Separate Certificate and CRL Keys Test20", + {bad_cert, {revoked, keyCompromise}}}, + { "4.4.21", "Invalid Separate Certificate and CRL Keys Test21", + {bad_cert, revocation_status_undetermined}} + ]). +%%----------------------------------------------------------------------------- +missing_basic_constraints(doc) -> + [""]; +missing_basic_constraints(suite) -> + []; +missing_basic_constraints(Config) when is_list(Config) -> + run([{ "4.6.1", "Invalid Missing basicConstraints Test1", + {bad_cert, missing_basic_constraint}}, + { "4.6.2", "Invalid cA False Test2", + {bad_cert, missing_basic_constraint}}, + { "4.6.3", "Invalid cA False Test3", + {bad_cert, missing_basic_constraint}}]). + +valid_basic_constraint(doc) -> + [""]; +valid_basic_constraint(suite) -> + []; +valid_basic_constraint(Config) when is_list(Config) -> + run([{"4.6.4", "Valid basicConstraints Not Critical Test4", ok}]). + +invalid_path_constraints(doc) -> + [""]; +invalid_path_constraints(suite) -> + []; +invalid_path_constraints(Config) when is_list(Config) -> + run([{ "4.6.5", "Invalid pathLenConstraint Test5", {bad_cert, max_path_length_reached}}, + { "4.6.6", "Invalid pathLenConstraint Test6", {bad_cert, max_path_length_reached}}, + { "4.6.9", "Invalid pathLenConstraint Test9", {bad_cert, max_path_length_reached}}, + { "4.6.10", "Invalid pathLenConstraint Test10", {bad_cert, max_path_length_reached}}, + { "4.6.11", "Invalid pathLenConstraint Test11", {bad_cert, max_path_length_reached}}, + { "4.6.12", "Invalid pathLenConstraint Test12", {bad_cert, max_path_length_reached}}, + { "4.6.16", "Invalid Self-Issued pathLenConstraint Test16", + {bad_cert, max_path_length_reached}}]). -signature_verification(doc) -> [""]; -signature_verification(suite) -> []; -signature_verification(Config) when is_list(Config) -> - run(signature_verification()). -validity_periods(doc) -> [""]; -validity_periods(suite) -> []; -validity_periods(Config) when is_list(Config) -> - run(validity_periods()). -verifying_name_chaining(doc) -> [""]; -verifying_name_chaining(suite) -> []; -verifying_name_chaining(Config) when is_list(Config) -> - run(verifying_name_chaining()). -basic_certificate_revocation_tests(doc) -> [""]; -basic_certificate_revocation_tests(suite) -> []; -basic_certificate_revocation_tests(Config) when is_list(Config) -> - run(basic_certificate_revocation_tests()). -verifying_paths_with_self_issued_certificates(doc) -> [""]; -verifying_paths_with_self_issued_certificates(suite) -> []; -verifying_paths_with_self_issued_certificates(Config) when is_list(Config) -> - run(verifying_paths_with_self_issued_certificates()). -verifying_basic_constraints(doc) -> [""]; -verifying_basic_constraints(suite) -> []; -verifying_basic_constraints(Config) when is_list(Config) -> - run(verifying_basic_constraints()). -key_usage(doc) -> [""]; -key_usage(suite) -> []; -key_usage(Config) when is_list(Config) -> - run(key_usage()). +valid_path_constraints(doc) -> + [""]; +valid_path_constraints(suite) -> + []; +valid_path_constraints(Config) when is_list(Config) -> + run([{ "4.6.7", "Valid pathLenConstraint Test7", ok}, + { "4.6.8", "Valid pathLenConstraint Test8", ok}, + { "4.6.13", "Valid pathLenConstraint Test13", ok}, + { "4.6.14", "Valid pathLenConstraint Test14", ok}, + { "4.6.15", "Valid Self-Issued pathLenConstraint Test15", ok}, + { "4.6.17", "Valid Self-Issued pathLenConstraint Test17", ok}]). + +%%----------------------------------------------------------------------------- +invalid_key_usage(doc) -> + [""]; +invalid_key_usage(suite) -> + []; +invalid_key_usage(Config) when is_list(Config) -> + run([{ "4.7.1", "Invalid keyUsage Critical keyCertSign False Test1", + {bad_cert,invalid_key_usage} }, + { "4.7.2", "Invalid keyUsage Not Critical keyCertSign False Test2", + {bad_cert,invalid_key_usage}}, + { "4.7.4", "Invalid keyUsage Critical cRLSign False Test4", + {bad_cert, revocation_status_undetermined}}, + { "4.7.5", "Invalid keyUsage Not Critical cRLSign False Test5", + {bad_cert, revocation_status_undetermined}} + ]). + +valid_key_usage(doc) -> + [""]; +valid_key_usage(suite) -> + []; +valid_key_usage(Config) when is_list(Config) -> + run([{ "4.7.3", "Valid keyUsage Not Critical Test3", ok}]). + +%%----------------------------------------------------------------------------- certificate_policies(doc) -> [""]; certificate_policies(suite) -> []; certificate_policies(Config) when is_list(Config) -> run(certificate_policies()). +%%----------------------------------------------------------------------------- require_explicit_policy(doc) -> [""]; require_explicit_policy(suite) -> []; require_explicit_policy(Config) when is_list(Config) -> run(require_explicit_policy()). +%%----------------------------------------------------------------------------- policy_mappings(doc) -> [""]; policy_mappings(suite) -> []; policy_mappings(Config) when is_list(Config) -> run(policy_mappings()). +%%----------------------------------------------------------------------------- inhibit_policy_mapping(doc) -> [""]; inhibit_policy_mapping(suite) -> []; inhibit_policy_mapping(Config) when is_list(Config) -> run(inhibit_policy_mapping()). +%%----------------------------------------------------------------------------- inhibit_any_policy(doc) -> [""]; inhibit_any_policy(suite) -> []; inhibit_any_policy(Config) when is_list(Config) -> run(inhibit_any_policy()). -name_constraints(doc) -> [""]; -name_constraints(suite) -> []; -name_constraints(Config) when is_list(Config) -> - run(name_constraints()). -distribution_points(doc) -> [""]; -distribution_points(suite) -> []; -distribution_points(Config) when is_list(Config) -> - run(distribution_points()). -delta_crls(doc) -> [""]; -delta_crls(suite) -> []; -delta_crls(Config) when is_list(Config) -> - run(delta_crls()). -private_certificate_extensions(doc) -> [""]; -private_certificate_extensions(suite) -> []; -private_certificate_extensions(Config) when is_list(Config) -> - run(private_certificate_extensions()). - -run() -> - Tests = - [signature_verification(), - validity_periods(), - verifying_name_chaining(), - %%basic_certificate_revocation_tests(), - verifying_paths_with_self_issued_certificates(), - verifying_basic_constraints(), - key_usage(), - %%certificate_policies(), - %%require_explicit_policy(), - %%policy_mappings(), - %%inhibit_policy_mapping(), - %%inhibit_any_policy(), - name_constraints(), - %distribution_points(), - %delta_crls(), - private_certificate_extensions() - ], - run(lists:append(Tests)). +%%----------------------------------------------------------------------------- + +valid_DN_name_constraints(doc) -> + [""]; +valid_DN_name_constraints(suite) -> + []; +valid_DN_name_constraints(Config) when is_list(Config) -> + run([{ "4.13.1", "Valid DN nameConstraints Test1", ok}, + { "4.13.4", "Valid DN nameConstraints Test4", ok}, + { "4.13.5", "Valid DN nameConstraints Test5", ok}, + { "4.13.6", "Valid DN nameConstraints Test6", ok}, + { "4.13.11", "Valid DN nameConstraints Test11", ok}, + { "4.13.14", "Valid DN nameConstraints Test14", ok}, + { "4.13.18", "Valid DN nameConstraints Test18", ok}, + { "4.13.19", "Valid Self-Issued DN nameConstraints Test19", ok}]). + +invalid_DN_name_constraints(doc) -> + [""]; +invalid_DN_name_constraints(suite) -> + []; +invalid_DN_name_constraints(Config) when is_list(Config) -> + run([{ "4.13.2", "Invalid DN nameConstraints Test2", {bad_cert, name_not_permitted}}, + { "4.13.3", "Invalid DN nameConstraints Test3", {bad_cert, name_not_permitted}}, + { "4.13.7", "Invalid DN nameConstraints Test7", {bad_cert, name_not_permitted}}, + { "4.13.8", "Invalid DN nameConstraints Test8", {bad_cert, name_not_permitted}}, + { "4.13.9", "Invalid DN nameConstraints Test9", {bad_cert, name_not_permitted}}, + { "4.13.10", "Invalid DN nameConstraints Test10",{bad_cert, name_not_permitted}}, + { "4.13.12", "Invalid DN nameConstraints Test12",{bad_cert, name_not_permitted}}, + { "4.13.13", "Invalid DN nameConstraints Test13",{bad_cert, name_not_permitted}}, + { "4.13.15", "Invalid DN nameConstraints Test15",{bad_cert, name_not_permitted}}, + { "4.13.16", "Invalid DN nameConstraints Test16",{bad_cert, name_not_permitted}}, + { "4.13.17", "Invalid DN nameConstraints Test17",{bad_cert, name_not_permitted}}, + { "4.13.20", "Invalid Self-Issued DN nameConstraints Test20", + {bad_cert, name_not_permitted}}]). + +valid_rfc822_name_constraints(doc) -> + [""]; +valid_rfc822_name_constraints(suite) -> + []; +valid_rfc822_name_constraints(Config) when is_list(Config) -> + run([{ "4.13.21", "Valid RFC822 nameConstraints Test21", ok}, + { "4.13.23", "Valid RFC822 nameConstraints Test23", ok}, + { "4.13.25", "Valid RFC822 nameConstraints Test25", ok}]). + + +invalid_rfc822_name_constraints(doc) -> + [""]; +invalid_rfc822_name_constraints(suite) -> + []; +invalid_rfc822_name_constraints(Config) when is_list(Config) -> + run([{ "4.13.22", "Invalid RFC822 nameConstraints Test22", + {bad_cert, name_not_permitted}}, + { "4.13.24", "Invalid RFC822 nameConstraints Test24", + {bad_cert, name_not_permitted}}, + { "4.13.26", "Invalid RFC822 nameConstraints Test26", + {bad_cert, name_not_permitted}}]). + +valid_DN_and_rfc822_name_constraints(doc) -> + [""]; +valid_DN_and_rfc822_name_constraints(suite) -> + []; +valid_DN_and_rfc822_name_constraints(Config) when is_list(Config) -> + run([{ "4.13.27", "Valid DN and RFC822 nameConstraints Test27", ok}]). + +invalid_DN_and_rfc822_name_constraints(doc) -> + [""]; +invalid_DN_and_rfc822_name_constraints(suite) -> + []; +invalid_DN_and_rfc822_name_constraints(Config) when is_list(Config) -> + run([{ "4.13.28", "Invalid DN and RFC822 nameConstraints Test28", + {bad_cert, name_not_permitted}}, + { "4.13.29", "Invalid DN and RFC822 nameConstraints Test29", + {bad_cert, name_not_permitted}}]). + +valid_dns_name_constraints(doc) -> + [""]; +valid_dns_name_constraints(suite) -> + []; +valid_dns_name_constraints(Config) when is_list(Config) -> + run([{ "4.13.30", "Valid DNS nameConstraints Test30", ok}, + { "4.13.32", "Valid DNS nameConstraints Test32", ok}]). + +invalid_dns_name_constraints(doc) -> + [""]; +invalid_dns_name_constraints(suite) -> + []; +invalid_dns_name_constraints(Config) when is_list(Config) -> + run([{ "4.13.31", "Invalid DNS nameConstraints Test31", {bad_cert, name_not_permitted}}, + { "4.13.33", "Invalid DNS nameConstraints Test33", {bad_cert, name_not_permitted}}, + { "4.13.38", "Invalid DNS nameConstraints Test38", {bad_cert, name_not_permitted}}]). + +valid_uri_name_constraints(doc) -> + [""]; +valid_uri_name_constraints(suite) -> + []; +valid_uri_name_constraints(Config) when is_list(Config) -> + run([{ "4.13.34", "Valid URI nameConstraints Test34", ok}, + { "4.13.36", "Valid URI nameConstraints Test36", ok}]). + +invalid_uri_name_constraints(doc) -> + [""]; +invalid_uri_name_constraints(suite) -> + []; +invalid_uri_name_constraints(Config) when is_list(Config) -> + run([{ "4.13.35", "Invalid URI nameConstraints Test35",{bad_cert, name_not_permitted}}, + { "4.13.37", "Invalid URI nameConstraints Test37",{bad_cert, name_not_permitted}}]). + +%%----------------------------------------------------------------------------- +delta_without_crl(doc) -> + [""]; +delta_without_crl(suite) -> + []; +delta_without_crl(Config) when is_list(Config) -> + run([{ "4.15.1", "Invalid deltaCRLIndicator No Base Test1",{bad_cert, + revocation_status_undetermined}}, + {"4.15.10", "Invalid delta-CRL Test10", {bad_cert, + revocation_status_undetermined}}]). + +valid_delta_crls(doc) -> + [""]; +valid_delta_crls(suite) -> + []; +valid_delta_crls(Config) when is_list(Config) -> + run([{ "4.15.2", "Valid delta-CRL Test2", ok}, + { "4.15.5", "Valid delta-CRL Test5", ok}, + { "4.15.7", "Valid delta-CRL Test7", ok}, + { "4.15.8", "Valid delta-CRL Test8", ok} + ]). + +invalid_delta_crls(doc) -> + [""]; +invalid_delta_crls(suite) -> + []; +invalid_delta_crls(Config) when is_list(Config) -> + run([{ "4.15.3", "Invalid delta-CRL Test3", {bad_cert,{revoked, keyCompromise}}}, + { "4.15.4", "Invalid delta-CRL Test4", {bad_cert,{revoked, keyCompromise}}}, + { "4.15.6", "Invalid delta-CRL Test6", {bad_cert,{revoked, keyCompromise}}}, + { "4.15.9", "Invalid delta-CRL Test9", {bad_cert,{revoked, keyCompromise}}}]). + +%%----------------------------------------------------------------------------- + +valid_distribution_points(doc) -> + [""]; +valid_distribution_points(suite) -> + []; +valid_distribution_points(Config) when is_list(Config) -> + run([{ "4.14.1", "Valid distributionPoint Test1", ok}, + { "4.14.4", "Valid distributionPoint Test4", ok}, + { "4.14.5", "Valid distributionPoint Test5", ok}, + { "4.14.7", "Valid distributionPoint Test7", ok} + ]). + +valid_distribution_points_no_issuing_distribution_point(doc) -> + [""]; +valid_distribution_points_no_issuing_distribution_point(suite) -> + []; +valid_distribution_points_no_issuing_distribution_point(Config) when is_list(Config) -> + run([{ "4.14.10", "Valid No issuingDistributionPoint Test10", ok} + ]). + +invalid_distribution_points(doc) -> + [""]; +invalid_distribution_points(suite) -> + []; +invalid_distribution_points(Config) when is_list(Config) -> + run([{ "4.14.2", "Invalid distributionPoint Test2", {bad_cert,{revoked, keyCompromise}}}, + { "4.14.3", "Invalid distributionPoint Test3", {bad_cert, + revocation_status_undetermined}}, + { "4.14.6", "Invalid distributionPoint Test6", {bad_cert,{revoked, keyCompromise}}}, + { "4.14.8", "Invalid distributionPoint Test8", {bad_cert, + revocation_status_undetermined}}, + { "4.14.9", "Invalid distributionPoint Test9", {bad_cert, + revocation_status_undetermined}} + ]). + +valid_only_contains(doc) -> + [""]; +valid_only_contains(suite) -> + []; +valid_only_contains(Config) when is_list(Config) -> + run([{ "4.14.13", "Valid onlyContainsCACerts CRL Test13", ok}]). + +invalid_only_contains(doc) -> + [""]; +invalid_only_contains(suite) -> + []; +invalid_only_contains(Config) when is_list(Config) -> + run([{ "4.14.11", "Invalid onlyContainsUserCerts CRL Test11", + {bad_cert, revocation_status_undetermined}}, + { "4.14.12", "Invalid onlyContainsCACerts CRL Test12", + {bad_cert, revocation_status_undetermined}}, + { "4.14.14", "Invalid onlyContainsAttributeCerts Test14", + {bad_cert, revocation_status_undetermined}} + ]). + +valid_only_some_reasons(doc) -> + [""]; +valid_only_some_reasons(suite) -> + []; +valid_only_some_reasons(Config) when is_list(Config) -> + run([{ "4.14.18", "Valid onlySomeReasons Test18", ok}, + { "4.14.19", "Valid onlySomeReasons Test19", ok} + ]). + +invalid_only_some_reasons(doc) -> + [""]; +invalid_only_some_reasons(suite) -> + []; +invalid_only_some_reasons(Config) when is_list(Config) -> + run([{ "4.14.15", "Invalid onlySomeReasons Test15", + {bad_cert,{revoked, keyCompromise}}}, + { "4.14.16", "Invalid onlySomeReasons Test16", + {bad_cert,{revoked, certificateHold}}}, + { "4.14.17", "Invalid onlySomeReasons Test17", + {bad_cert, revocation_status_undetermined}}, + { "4.14.20", "Invalid onlySomeReasons Test20", + {bad_cert,{revoked, keyCompromise}}}, + { "4.14.21", "Invalid onlySomeReasons Test21", + {bad_cert,{revoked, affiliationChanged}}} + ]). + +valid_indirect_crl(doc) -> + [""]; +valid_indirect_crl(suite) -> + []; +valid_indirect_crl(Config) when is_list(Config) -> + run([{ "4.14.22", "Valid IDP with indirectCRL Test22", ok}, + { "4.14.24", "Valid IDP with indirectCRL Test24", ok}, + { "4.14.25", "Valid IDP with indirectCRL Test25", ok} + ]). + +invalid_indirect_crl(doc) -> + [""]; +invalid_indirect_crl(suite) -> + []; +invalid_indirect_crl(Config) when is_list(Config) -> + run([{ "4.14.23", "Invalid IDP with indirectCRL Test23", + {bad_cert,{revoked, keyCompromise}}}, + { "4.14.26", "Invalid IDP with indirectCRL Test26", + {bad_cert, revocation_status_undetermined}} + ]). + +valid_crl_issuer(doc) -> + [""]; +valid_crl_issuer(suite) -> + []; +valid_crl_issuer(Config) when is_list(Config) -> + run([{ "4.14.28", "Valid cRLIssuer Test28", ok}%%, + %%{ "4.14.29", "Valid cRLIssuer Test29", ok}, + %%{ "4.14.33", "Valid cRLIssuer Test33", ok} + ]). + +invalid_crl_issuer(doc) -> + [""]; +invalid_crl_issuer(suite) -> + []; +invalid_crl_issuer(Config) when is_list(Config) -> + run([ + { "4.14.27", "Invalid cRLIssuer Test27", {bad_cert, revocation_status_undetermined}}, + { "4.14.31", "Invalid cRLIssuer Test31", {bad_cert,{revoked, keyCompromise}}}, + { "4.14.32", "Invalid cRLIssuer Test32", {bad_cert,{revoked, keyCompromise}}}, + { "4.14.34", "Invalid cRLIssuer Test34", {bad_cert,{revoked, keyCompromise}}}, + { "4.14.35", "Invalid cRLIssuer Test35", {bad_cert, revocation_status_undetermined}} + ]). + + +%%distribution_points() -> + %%{ "4.14", "Distribution Points" }, +%% [ + %% Although this test is valid it has a circular dependency. As a result + %% an attempt is made to reursively checks a CRL path and rejected due to + %% a CRL path validation error. PKITS notes suggest this test does not + %% need to be run due to this issue. +%% { "4.14.30", "Valid cRLIssuer Test30", 54 }]. + + +%%----------------------------------------------------------------------------- + +unknown_critical_extension(doc) -> + [""]; +unknown_critical_extension(suite) -> + []; +unknown_critical_extension(Config) when is_list(Config) -> + run([{ "4.16.2", "Invalid Unknown Critical Certificate Extension Test2", + {bad_cert,unknown_critical_extension}}]). + +unknown_not_critical_extension(doc) -> + [""]; +unknown_not_critical_extension(suite) -> + []; +unknown_not_critical_extension(Config) when is_list(Config) -> + run([{ "4.16.1", "Valid Unknown Not Critical Certificate Extension Test1", ok}]). + +%%----------------------------------------------------------------------------- run(Tests) -> File = file(?CERTS,"TrustAnchorRootCertificate.crt"), {ok, TA} = file:read_file(File), run(Tests, TA). run({Chap, Test, Result}, TA) -> - CertChain = sort_chain(read_certs(Test),TA, [], false), - try public_key:pkix_path_validation(TA, CertChain, []) of - {Result, _} -> ok; + CertChain = sort_chain(read_certs(Test),TA, [], false, Chap), + Options = path_validation_options(TA, Chap,Test), + try public_key:pkix_path_validation(TA, CertChain, Options) of + {Result, _} -> ok; {error,Result} when Result =/= ok -> ok; - {error,Error} when is_integer(Result) -> - ?warning(" ~p~n Got ~p expected ~p~n",[Test, Error, Result]); - {error,Error} when Result =/= ok -> - ?error(" minor ~p~n Got ~p expected ~p~n",[Test, Error, Result]); {error, Error} -> ?error(" ~p ~p~n Expected ~p got ~p ~n", [Chap, Test, Result, Error]), fail; - {ok, _} when Result =/= ok -> + {ok, _OK} when Result =/= ok -> ?error(" ~p ~p~n Expected ~p got ~p ~n", [Chap, Test, Result, ok]), fail catch Type:Reason -> @@ -181,14 +821,318 @@ run([Test|Rest],TA) -> run(Rest,TA); run([],_) -> ok. +path_validation_options(TA, Chap, Test) -> + case needs_crl_options(Chap) of + true -> + crl_options(TA, Test); + false -> + Fun = + fun(_,{bad_cert, _} = Reason, _) -> + {fail, Reason}; + (_,{extension, _}, UserState) -> + {unknown, UserState}; + (_, Valid, UserState) when Valid == valid; + Valid == valid_peer -> + {valid, UserState} + end, + [{verify_fun, {Fun, []}}] + end. + +needs_crl_options("4.4" ++ _) -> + true; +needs_crl_options("4.5" ++ _) -> + true; +needs_crl_options("4.7.4" ++ _) -> + true; +needs_crl_options("4.7.5" ++ _) -> + true; +needs_crl_options("4.14" ++ _) -> + true; +needs_crl_options("4.15" ++ _) -> + true; +needs_crl_options(_) -> + false. + +crl_options(TA, Test) -> + case read_crls(Test) of + [] -> + []; + CRLs -> + Fun = + fun(_,{bad_cert, _} = Reason, _) -> + {fail, Reason}; + (_,{extension, + #'Extension'{extnID = ?'id-ce-cRLDistributionPoints', + extnValue = Value}}, UserState0) -> + UserState = update_crls(Value, UserState0), + {valid, UserState}; + (_,{extension, _}, UserState) -> + {unknown, UserState}; + (OtpCert, Valid, UserState) when Valid == valid; + Valid == valid_peer -> + {ErlCerts, CRLs} = UserState#verify_state.crl_info, + CRLInfo0 = + crl_info(OtpCert, + ErlCerts,[{DerCRL, public_key:der_decode('CertificateList', + DerCRL)} || DerCRL <- CRLs], + []), + CRLInfo = lists:reverse(CRLInfo0), + Certs = UserState#verify_state.certs_db, + Fun = fun(DP, CRLtoValidate, Id, CertsDb) -> + trusted_cert_and_path(DP, CRLtoValidate, Id, CertsDb) + end, + Ignore = ignore_sign_test_when_building_path(Test), + case public_key:pkix_crls_validate(OtpCert, CRLInfo, + [{issuer_fun,{Fun, {Ignore, Certs}}}]) of + valid -> + {valid, UserState}; + Reason -> + {fail, Reason} + end + end, + + Certs = read_certs(Test), + ErlCerts = [public_key:pkix_decode_cert(Cert, otp) || Cert <- Certs], + + [{verify_fun, {Fun, #verify_state{certs_db = [TA| Certs], + crl_info = {ErlCerts, CRLs}}}}] + end. + +crl_info(_, _, [], Acc) -> + Acc; +crl_info(OtpCert, Certs, [{_, #'CertificateList'{tbsCertList = + #'TBSCertList'{issuer = Issuer, + crlExtensions = CRLExtensions}}} + = CRL | Rest], Acc) -> + OtpTBSCert = OtpCert#'OTPCertificate'.tbsCertificate, + Extensions = OtpTBSCert#'OTPTBSCertificate'.extensions, + ExtList = pubkey_cert:extensions_list(CRLExtensions), + DPs = case pubkey_cert:select_extension(?'id-ce-cRLDistributionPoints', Extensions) of + #'Extension'{extnValue = Value} -> + lists:map(fun(Point) -> pubkey_cert_records:transform(Point, decode) end, Value); + _ -> + case same_issuer(OtpCert, Issuer) of + true -> + [make_dp(ExtList, asn1_NOVALUE, Issuer)]; + false -> + [make_dp(ExtList, Issuer, ignore)] + end + end, + DPsCRLs = lists:map(fun(DP) -> {DP, CRL} end, DPs), + crl_info(OtpCert, Certs, Rest, DPsCRLs ++ Acc). + +ignore_sign_test_when_building_path("Invalid Bad CRL Signature Test4") -> + true; +ignore_sign_test_when_building_path(_) -> + false. + +same_issuer(OTPCert, Issuer) -> + DecIssuer = pubkey_cert_records:transform(Issuer, decode), + OTPTBSCert = OTPCert#'OTPCertificate'.tbsCertificate, + CertIssuer = OTPTBSCert#'OTPTBSCertificate'.issuer, + pubkey_cert:is_issuer(DecIssuer, CertIssuer). + +make_dp(Extensions, Issuer0, DpInfo) -> + {Issuer, Point} = mk_issuer_dp(Issuer0, DpInfo), + case pubkey_cert:select_extension('id-ce-cRLReason', Extensions) of + #'Extension'{extnValue = Reasons} -> + #'DistributionPoint'{cRLIssuer = Issuer, + reasons = Reasons, + distributionPoint = Point}; + _ -> + #'DistributionPoint'{cRLIssuer = Issuer, + reasons = [unspecified, keyCompromise, + cACompromise, affiliationChanged, superseded, + cessationOfOperation, certificateHold, + removeFromCRL, privilegeWithdrawn, aACompromise], + distributionPoint = Point} + end. + +mk_issuer_dp(asn1_NOVALUE, Issuer) -> + {asn1_NOVALUE, {fullName, [{directoryName, Issuer}]}}; +mk_issuer_dp(Issuer, _) -> + {[{directoryName, Issuer}], asn1_NOVALUE}. + +update_crls(_, State) -> + State. + +trusted_cert_and_path(DP, CRL, Id, {Ignore, CertsList}) -> + case crl_issuer(crl_issuer_name(DP), CRL, Id, CertsList, CertsList, Ignore) of + {ok, IssuerCert, DerIssuerCert} -> + Certs = [{public_key:pkix_decode_cert(Cert, otp), Cert} || Cert <- CertsList], + CertChain = build_chain(Certs, Certs, IssuerCert, Ignore, [DerIssuerCert]), + {ok, public_key:pkix_decode_cert(hd(CertChain), otp), CertChain}; + Other -> + Other + end. + +crl_issuer_name(#'DistributionPoint'{cRLIssuer = asn1_NOVALUE}) -> + undefined; +crl_issuer_name(#'DistributionPoint'{cRLIssuer = [{directoryName, Issuer}]}) -> + pubkey_cert_records:transform(Issuer, decode). + +build_chain([],_, _, _,Acc) -> + Acc; + +build_chain([{First, DerFirst}|Certs], All, Cert, Ignore, Acc) -> + case public_key:pkix_is_self_signed(Cert) andalso is_test_root(Cert) of + true -> + Acc; + false -> + case public_key:pkix_is_issuer(Cert, First) + %%andalso check_extension_cert_signer(First) + andalso is_signer(First, Cert, Ignore) + of + true -> + build_chain(All, All, First, Ignore, [DerFirst | Acc]); + false -> + build_chain(Certs, All, Cert, Ignore, Acc) + end + end. + +is_signer(_,_, true) -> + true; +is_signer(Signer, #'OTPCertificate'{} = Cert,_) -> + TBSCert = Signer#'OTPCertificate'.tbsCertificate, + PublicKeyInfo = TBSCert#'OTPTBSCertificate'.subjectPublicKeyInfo, + PublicKey = PublicKeyInfo#'OTPSubjectPublicKeyInfo'.subjectPublicKey, + AlgInfo = PublicKeyInfo#'OTPSubjectPublicKeyInfo'.algorithm, + PublicKeyParams = AlgInfo#'PublicKeyAlgorithm'.parameters, + try pubkey_cert:validate_signature(Cert, public_key:pkix_encode('OTPCertificate', + Cert, otp), + PublicKey, PublicKeyParams, true, ?DEFAULT_VERIFYFUN) of + true -> + true + catch + _:_ -> + false + end; +is_signer(Signer, #'CertificateList'{} = CRL, _) -> + TBSCert = Signer#'OTPCertificate'.tbsCertificate, + PublicKeyInfo = TBSCert#'OTPTBSCertificate'.subjectPublicKeyInfo, + PublicKey = PublicKeyInfo#'OTPSubjectPublicKeyInfo'.subjectPublicKey, + AlgInfo = PublicKeyInfo#'OTPSubjectPublicKeyInfo'.algorithm, + PublicKeyParams = AlgInfo#'PublicKeyAlgorithm'.parameters, + pubkey_crl:verify_crl_signature(CRL, public_key:pkix_encode('CertificateList', + CRL, plain), + PublicKey, PublicKeyParams). + +is_test_root(OtpCert) -> + TBSCert = OtpCert#'OTPCertificate'.tbsCertificate, + {rdnSequence, AtterList} = TBSCert#'OTPTBSCertificate'.issuer, + lists:member([{'AttributeTypeAndValue',{2,5,4,3},{printableString,"Trust Anchor"}}], + AtterList). + +check_extension_cert_signer(OtpCert) -> + TBSCert = OtpCert#'OTPCertificate'.tbsCertificate, + Extensions = TBSCert#'OTPTBSCertificate'.extensions, + case pubkey_cert:select_extension(?'id-ce-keyUsage', Extensions) of + #'Extension'{extnValue = KeyUse} -> + lists:member(keyCertSign, KeyUse); + _ -> + true + end. + +check_extension_crl_signer(OtpCert) -> + TBSCert = OtpCert#'OTPCertificate'.tbsCertificate, + Extensions = TBSCert#'OTPTBSCertificate'.extensions, + case pubkey_cert:select_extension(?'id-ce-keyUsage', Extensions) of + #'Extension'{extnValue = KeyUse} -> + lists:member(cRLSign, KeyUse); + _ -> + true + end. + +crl_issuer(undefined, CRL, issuer_not_found, _, CertsList, Ignore) -> + crl_issuer(CRL, CertsList, Ignore); + +crl_issuer(IssuerName, CRL, issuer_not_found, CertsList, CertsList, Ignore) -> + crl_issuer(IssuerName, CRL, IssuerName, CertsList, CertsList, Ignore); + +crl_issuer(undefined, CRL, Id, [Cert | Rest], All, false) -> + ErlCert = public_key:pkix_decode_cert(Cert, otp), + TBSCertificate = ErlCert#'OTPCertificate'.tbsCertificate, + SerialNumber = TBSCertificate#'OTPTBSCertificate'.serialNumber, + Issuer = public_key:pkix_normalize_name( + TBSCertificate#'OTPTBSCertificate'.subject), + Bool = is_signer(ErlCert, CRL, false), + case {SerialNumber, Issuer} of + Id when Bool == true -> + {ok, ErlCert, Cert}; + _ -> + crl_issuer(undefined, CRL, Id, Rest, All, false) + end; + +crl_issuer(IssuerName, CRL, Id, [Cert | Rest], All, false) -> + ErlCert = public_key:pkix_decode_cert(Cert, otp), + TBSCertificate = ErlCert#'OTPCertificate'.tbsCertificate, + SerialNumber = TBSCertificate#'OTPTBSCertificate'.serialNumber, + %%Issuer = public_key:pkix_normalize_name( + %% TBSCertificate#'OTPTBSCertificate'.subject), + Bool = is_signer(ErlCert, CRL, false), + case {SerialNumber, IssuerName} of + Id when Bool == true -> + {ok, ErlCert, Cert}; + {_, IssuerName} when Bool == true -> + {ok, ErlCert, Cert}; + _ -> + crl_issuer(IssuerName, CRL, Id, Rest, All, false) + end; + +crl_issuer(undefined, CRL, _, [], CertsList, Ignore) -> + crl_issuer(CRL, CertsList, Ignore); +crl_issuer(CRLName, CRL, _, [], CertsList, Ignore) -> + crl_issuer(CRLName, CRL, CertsList, Ignore). + + +crl_issuer(_, [],_) -> + {error, issuer_not_found}; +crl_issuer(CRL, [Cert | Rest], Ignore) -> + ErlCert = public_key:pkix_decode_cert(Cert, otp), + case public_key:pkix_is_issuer(CRL, ErlCert) andalso + check_extension_crl_signer(ErlCert) andalso + is_signer(ErlCert, CRL, Ignore) + of + true -> + {ok, ErlCert,Cert}; + false -> + crl_issuer(CRL, Rest, Ignore) + end. + +crl_issuer(_,_, [],_) -> + {error, issuer_not_found}; +crl_issuer(IssuerName, CRL, [Cert | Rest], Ignore) -> + ErlCert = public_key:pkix_decode_cert(Cert, otp), + TBSCertificate = ErlCert#'OTPCertificate'.tbsCertificate, + Issuer = public_key:pkix_normalize_name( + TBSCertificate#'OTPTBSCertificate'.subject), + + case + public_key:pkix_is_issuer(CRL, ErlCert) andalso + check_extension_crl_signer(ErlCert) andalso + is_signer(ErlCert, CRL, Ignore) + of + true -> + case pubkey_cert:is_issuer(Issuer, IssuerName) of + true -> + {ok, ErlCert,Cert}; + false -> + crl_issuer(IssuerName, CRL, Rest, Ignore) + end; + false -> + crl_issuer(IssuerName, CRL, Rest, Ignore) + end. read_certs(Test) -> File = test_file(Test), - %% io:format("Read ~p ",[File]), Ders = erl_make_certs:pem_to_der(File), - %% io:format("Ders ~p ~n",[length(Ders)]), [Cert || {'Certificate', Cert, not_encrypted} <- Ders]. +read_crls(Test) -> + File = test_file(Test), + Ders = erl_make_certs:pem_to_der(File), + [CRL || {'CertificateList', CRL, not_encrypted} <- Ders]. + test_file(Test) -> file(?CONV, lists:append(string:tokens(Test, " -")) ++ ".pem"). @@ -206,118 +1150,89 @@ file(Sub,File) -> end, AbsFile. -sort_chain([First|Certs], TA, Try, Found) -> +sort_chain(Certs, TA, Acc, Bool, Chap) when Chap == "4.5.3"-> + [CA, Entity, Self] = do_sort_chain(Certs, TA, Acc, Bool, Chap), + [CA, Self, Entity]; +sort_chain(Certs, TA, Acc, Bool, Chap) when Chap == "4.5.4"; + Chap == "4.5.5" -> + [CA, Entity, _Self] = do_sort_chain(Certs, TA, Acc, Bool, Chap), + [CA, Entity]; + +sort_chain(Certs, TA, Acc, Bool, Chap) when Chap == "4.14.24"; + Chap == "4.14.25"; + Chap == "4.14.26"; + Chap == "4.14.27"; + Chap == "4.14.31"; + Chap == "4.14.32"; + Chap == "4.14.33" -> + [_OtherCA, Entity, CA] = do_sort_chain(Certs, TA, Acc, Bool, Chap), + [CA, Entity]; + +sort_chain(Certs, TA, Acc, Bool, Chap) when Chap == "4.14.28"; + Chap == "4.14.29" -> + [CA, _OtherCA, Entity] = do_sort_chain(Certs, TA, Acc, Bool, Chap), + [CA, Entity]; + + +sort_chain(Certs, TA, Acc, Bool, Chap) when Chap == "4.14.33" -> + [Entity, CA, _OtherCA] = do_sort_chain(Certs, TA, Acc, Bool, Chap), + [CA, Entity]; + + +sort_chain(Certs, TA, Acc, Bool, Chap) -> + do_sort_chain(Certs, TA, Acc, Bool, Chap). + +do_sort_chain([First], TA, Try, Found, Chap) when Chap == "4.5.6"; + Chap == "4.5.7"; + Chap == "4.4.19"; + Chap == "4.4.20"; + Chap == "4.4.21"-> case public_key:pkix_is_issuer(First,TA) of true -> - [First|sort_chain(Certs,First,Try,true)]; + [First|do_sort_chain([],First,Try,true, Chap)]; false -> - sort_chain(Certs,TA,[First|Try],Found) + do_sort_chain([],TA,[First|Try],Found, Chap) end; -sort_chain([], _, [],_) -> []; -sort_chain([], Valid, Check, true) -> - sort_chain(lists:reverse(Check), Valid, [], false); -sort_chain([], _Valid, Check, false) -> +do_sort_chain([First|Certs], TA, Try, Found, Chap) when Chap == "4.5.6"; + Chap == "4.5.7"; + Chap == "4.4.19"; + Chap == "4.4.20"; + Chap == "4.4.21"-> +%% case check_extension_cert_signer(public_key:pkix_decode_cert(First, otp)) of +%% true -> + case public_key:pkix_is_issuer(First,TA) of + true -> + [First|do_sort_chain(Certs,First,Try,true, Chap)]; + false -> + do_sort_chain(Certs,TA,[First|Try],Found, Chap) + end; +%% false -> +%% do_sort_chain(Certs, TA, Try, Found, Chap) +%% end; + +do_sort_chain([First|Certs], TA, Try, Found, Chap) -> + case public_key:pkix_is_issuer(First,TA) of + true -> + [First|do_sort_chain(Certs,First,Try,true, Chap)]; + false -> + do_sort_chain(Certs,TA,[First|Try],Found, Chap) + end; + +do_sort_chain([], _, [],_, _) -> []; +do_sort_chain([], Valid, Check, true, Chap) -> + do_sort_chain(lists:reverse(Check), Valid, [], false, Chap); +do_sort_chain([], _Valid, Check, false, _) -> Check. -signature_verification() -> - %% "4.1", "Signature Verification" , - [{ "4.1.1", "Valid Signatures Test1", ok}, - { "4.1.2", "Invalid CA Signature Test2", {bad_cert,invalid_signature}}, - { "4.1.3", "Invalid EE Signature Test3", {bad_cert,invalid_signature}}, - { "4.1.4", "Valid DSA Signatures Test4", ok}, - { "4.1.5", "Valid DSA Parameter Inheritance Test5", ok}, - { "4.1.6", "Invalid DSA Signature Test6", {bad_cert,invalid_signature}}]. -validity_periods() -> - %% { "4.2", "Validity Periods" }, - [{ "4.2.1", "Invalid CA notBefore Date Test1", {bad_cert, cert_expired}}, - { "4.2.2", "Invalid EE notBefore Date Test2", {bad_cert, cert_expired}}, - { "4.2.3", "Valid pre2000 UTC notBefore Date Test3", ok}, - { "4.2.4", "Valid GeneralizedTime notBefore Date Test4", ok}, - { "4.2.5", "Invalid CA notAfter Date Test5", {bad_cert, cert_expired}}, - { "4.2.6", "Invalid EE notAfter Date Test6", {bad_cert, cert_expired}}, - { "4.2.7", "Invalid pre2000 UTC EE notAfter Date Test7", {bad_cert, cert_expired}}, - { "4.2.8", "Valid GeneralizedTime notAfter Date Test8", ok}]. -verifying_name_chaining() -> - %%{ "4.3", "Verifying Name Chaining" }, - [{ "4.3.1", "Invalid Name Chaining EE Test1", {bad_cert, invalid_issuer}}, - { "4.3.2", "Invalid Name Chaining Order Test2", {bad_cert, invalid_issuer}}, - { "4.3.3", "Valid Name Chaining Whitespace Test3", ok}, - { "4.3.4", "Valid Name Chaining Whitespace Test4", ok}, - { "4.3.5", "Valid Name Chaining Capitalization Test5", ok}, - { "4.3.6", "Valid Name Chaining UIDs Test6", ok}, - { "4.3.7", "Valid RFC3280 Mandatory Attribute Types Test7", ok}, - { "4.3.8", "Valid RFC3280 Optional Attribute Types Test8", ok}, - { "4.3.9", "Valid UTF8String Encoded Names Test9", ok}, - { "4.3.10", "Valid Rollover from PrintableString to UTF8String Test10", ok}, - { "4.3.11", "Valid UTF8String Case Insensitive Match Test11", ok}]. -basic_certificate_revocation_tests() -> - %%{ "4.4", "Basic Certificate Revocation Tests" }, - [{ "4.4.1", "Missing CRL Test1", 3 }, - { "4.4.2", "Invalid Revoked CA Test2", 23 }, - { "4.4.3", "Invalid Revoked EE Test3", 23 }, - { "4.4.4", "Invalid Bad CRL Signature Test4", 8 }, - { "4.4.5", "Invalid Bad CRL Issuer Name Test5", 3 }, - { "4.4.6", "Invalid Wrong CRL Test6", 3 }, - { "4.4.7", "Valid Two CRLs Test7", ok}, - - %% The test document suggests these should return certificate revoked... - %% Subsquent discussion has concluded they should not due to unhandle - %% critical CRL extensions. - { "4.4.8", "Invalid Unknown CRL Entry Extension Test8", 36 }, - { "4.4.9", "Invalid Unknown CRL Extension Test9", 36 }, - - { "4.4.10", "Invalid Unknown CRL Extension Test10", 36 }, - { "4.4.11", "Invalid Old CRL nextUpdate Test11", 12 }, - { "4.4.12", "Invalid pre2000 CRL nextUpdate Test12", 12 }, - { "4.4.13", "Valid GeneralizedTime CRL nextUpdate Test13", ok}, - { "4.4.14", "Valid Negative Serial Number Test14", ok}, - { "4.4.15", "Invalid Negative Serial Number Test15", 23 }, - { "4.4.16", "Valid Long Serial Number Test16", ok}, - { "4.4.17", "Valid Long Serial Number Test17", ok}, - { "4.4.18", "Invalid Long Serial Number Test18", 23 }, - { "4.4.19", "Valid Separate Certificate and CRL Keys Test19", ok}, - { "4.4.20", "Invalid Separate Certificate and CRL Keys Test20", 23 }, - - %% CRL path is revoked so get a CRL path validation error - { "4.4.21", "Invalid Separate Certificate and CRL Keys Test21", 54 }]. -verifying_paths_with_self_issued_certificates() -> - %%{ "4.5", "Verifying Paths with Self-Issued Certificates" }, - [{ "4.5.1", "Valid Basic Self-Issued Old With New Test1", ok}, - %%{ "4.5.2", "Invalid Basic Self-Issued Old With New Test2", 23 }, - %%{ "4.5.3", "Valid Basic Self-Issued New With Old Test3", ok}, - %%{ "4.5.4", "Valid Basic Self-Issued New With Old Test4", ok}, - { "4.5.5", "Invalid Basic Self-Issued New With Old Test5", 23 }, - %%{ "4.5.6", "Valid Basic Self-Issued CRL Signing Key Test6", ok}, - { "4.5.7", "Invalid Basic Self-Issued CRL Signing Key Test7", 23 }, - { "4.5.8", "Invalid Basic Self-Issued CRL Signing Key Test8", {bad_cert,invalid_key_usage} }]. -verifying_basic_constraints() -> - [%%{ "4.6", "Verifying Basic Constraints" }, - { "4.6.1", "Invalid Missing basicConstraints Test1", - {bad_cert, missing_basic_constraint} }, - { "4.6.2", "Invalid cA False Test2", {bad_cert, missing_basic_constraint}}, - { "4.6.3", "Invalid cA False Test3", {bad_cert, missing_basic_constraint}}, - { "4.6.4", "Valid basicConstraints Not Critical Test4", ok}, - { "4.6.5", "Invalid pathLenConstraint Test5", {bad_cert, max_path_length_reached}}, - { "4.6.6", "Invalid pathLenConstraint Test6", {bad_cert, max_path_length_reached}}, - { "4.6.7", "Valid pathLenConstraint Test7", ok}, - { "4.6.8", "Valid pathLenConstraint Test8", ok}, - { "4.6.9", "Invalid pathLenConstraint Test9", {bad_cert, max_path_length_reached}}, - { "4.6.10", "Invalid pathLenConstraint Test10", {bad_cert, max_path_length_reached}}, - { "4.6.11", "Invalid pathLenConstraint Test11", {bad_cert, max_path_length_reached}}, - { "4.6.12", "Invalid pathLenConstraint Test12", {bad_cert, max_path_length_reached}}, - { "4.6.13", "Valid pathLenConstraint Test13", ok}, - { "4.6.14", "Valid pathLenConstraint Test14", ok}, - { "4.6.15", "Valid Self-Issued pathLenConstraint Test15", ok}, - { "4.6.16", "Invalid Self-Issued pathLenConstraint Test16", {bad_cert, max_path_length_reached}}, - { "4.6.17", "Valid Self-Issued pathLenConstraint Test17", ok}]. -key_usage() -> - %%{ "4.7", "Key Usage" }, - [{ "4.7.1", "Invalid keyUsage Critical keyCertSign False Test1", {bad_cert,invalid_key_usage} }, - { "4.7.2", "Invalid keyUsage Not Critical keyCertSign False Test2", {bad_cert,invalid_key_usage} }, - { "4.7.3", "Valid keyUsage Not Critical Test3", ok} - %%,{ "4.7.4", "Invalid keyUsage Critical cRLSign False Test4", 35 } - %%,{ "4.7.5", "Invalid keyUsage Not Critical cRLSign False Test5", 35 } - ]. +error(Format, Args, File0, Line) -> + File = filename:basename(File0), + Pid = group_leader(), + Pid ! {failed, File, Line}, + io:format(Pid, "~s(~p): ERROR"++Format, [File,Line|Args]). + +warning(Format, Args, File0, Line) -> + File = filename:basename(File0), + io:format("~s(~p): Warning "++Format, [File,Line|Args]). %% Certificate policy tests need special handling. They can have several %% sub tests and we need to check the outputs are correct. @@ -425,182 +1340,3 @@ inhibit_any_policy() -> {"4.12.8", "Invalid Self-Issued inhibitAnyPolicy Test8", 43 }, {"4.12.9", "Valid Self-Issued inhibitAnyPolicy Test9", ok}, {"4.12.10", "Invalid Self-Issued inhibitAnyPolicy Test10", 43 }]. - -name_constraints() -> - %%{ "4.13", "Name Constraints" }, - [{ "4.13.1", "Valid DN nameConstraints Test1", ok}, - { "4.13.2", "Invalid DN nameConstraints Test2", {bad_cert, name_not_permitted}}, - { "4.13.3", "Invalid DN nameConstraints Test3", {bad_cert, name_not_permitted}}, - { "4.13.4", "Valid DN nameConstraints Test4", ok}, - { "4.13.5", "Valid DN nameConstraints Test5", ok}, - { "4.13.6", "Valid DN nameConstraints Test6", ok}, - { "4.13.7", "Invalid DN nameConstraints Test7", {bad_cert, name_not_permitted}}, - { "4.13.8", "Invalid DN nameConstraints Test8", {bad_cert, name_not_permitted}}, - { "4.13.9", "Invalid DN nameConstraints Test9", {bad_cert, name_not_permitted}}, - { "4.13.10", "Invalid DN nameConstraints Test10", {bad_cert, name_not_permitted}}, - { "4.13.11", "Valid DN nameConstraints Test11", ok}, - { "4.13.12", "Invalid DN nameConstraints Test12", {bad_cert, name_not_permitted}}, - { "4.13.13", "Invalid DN nameConstraints Test13", {bad_cert, name_not_permitted}}, - { "4.13.14", "Valid DN nameConstraints Test14", ok}, - { "4.13.15", "Invalid DN nameConstraints Test15", {bad_cert, name_not_permitted}}, - { "4.13.16", "Invalid DN nameConstraints Test16", {bad_cert, name_not_permitted}}, - { "4.13.17", "Invalid DN nameConstraints Test17", {bad_cert, name_not_permitted}}, - { "4.13.18", "Valid DN nameConstraints Test18", ok}, - { "4.13.19", "Valid Self-Issued DN nameConstraints Test19", ok}, - { "4.13.20", "Invalid Self-Issued DN nameConstraints Test20", {bad_cert, name_not_permitted} }, - { "4.13.21", "Valid RFC822 nameConstraints Test21", ok}, - { "4.13.22", "Invalid RFC822 nameConstraints Test22", {bad_cert, name_not_permitted} }, - { "4.13.23", "Valid RFC822 nameConstraints Test23", ok}, - { "4.13.24", "Invalid RFC822 nameConstraints Test24", {bad_cert, name_not_permitted} }, - { "4.13.25", "Valid RFC822 nameConstraints Test25", ok}, - { "4.13.26", "Invalid RFC822 nameConstraints Test26", {bad_cert, name_not_permitted}}, - { "4.13.27", "Valid DN and RFC822 nameConstraints Test27", ok}, - { "4.13.28", "Invalid DN and RFC822 nameConstraints Test28", {bad_cert, name_not_permitted} }, - { "4.13.29", "Invalid DN and RFC822 nameConstraints Test29", {bad_cert, name_not_permitted} }, - { "4.13.30", "Valid DNS nameConstraints Test30", ok}, - { "4.13.31", "Invalid DNS nameConstraints Test31", {bad_cert, name_not_permitted} }, - { "4.13.32", "Valid DNS nameConstraints Test32", ok}, - { "4.13.33", "Invalid DNS nameConstraints Test33", {bad_cert, name_not_permitted}}, - { "4.13.34", "Valid URI nameConstraints Test34", ok}, - { "4.13.35", "Invalid URI nameConstraints Test35", {bad_cert, name_not_permitted} }, - { "4.13.36", "Valid URI nameConstraints Test36", ok}, - { "4.13.37", "Invalid URI nameConstraints Test37", {bad_cert, name_not_permitted}}, - { "4.13.38", "Invalid DNS nameConstraints Test38", {bad_cert, name_not_permitted} }]. -distribution_points() -> - %%{ "4.14", "Distribution Points" }, - [{ "4.14.1", "Valid distributionPoint Test1", ok}, - { "4.14.2", "Invalid distributionPoint Test2", 23 }, - { "4.14.3", "Invalid distributionPoint Test3", 44 }, - { "4.14.4", "Valid distributionPoint Test4", ok}, - { "4.14.5", "Valid distributionPoint Test5", ok}, - { "4.14.6", "Invalid distributionPoint Test6", 23 }, - { "4.14.7", "Valid distributionPoint Test7", ok}, - { "4.14.8", "Invalid distributionPoint Test8", 44 }, - { "4.14.9", "Invalid distributionPoint Test9", 44 }, - { "4.14.10", "Valid No issuingDistributionPoint Test10", ok}, - { "4.14.11", "Invalid onlyContainsUserCerts CRL Test11", 44 }, - { "4.14.12", "Invalid onlyContainsCACerts CRL Test12", 44 }, - { "4.14.13", "Valid onlyContainsCACerts CRL Test13", ok}, - { "4.14.14", "Invalid onlyContainsAttributeCerts Test14", 44 }, - { "4.14.15", "Invalid onlySomeReasons Test15", 23 }, - { "4.14.16", "Invalid onlySomeReasons Test16", 23 }, - { "4.14.17", "Invalid onlySomeReasons Test17", 3 }, - { "4.14.18", "Valid onlySomeReasons Test18", ok}, - { "4.14.19", "Valid onlySomeReasons Test19", ok}, - { "4.14.20", "Invalid onlySomeReasons Test20", 23 }, - { "4.14.21", "Invalid onlySomeReasons Test21", 23 }, - { "4.14.22", "Valid IDP with indirectCRL Test22", ok}, - { "4.14.23", "Invalid IDP with indirectCRL Test23", 23 }, - { "4.14.24", "Valid IDP with indirectCRL Test24", ok}, - { "4.14.25", "Valid IDP with indirectCRL Test25", ok}, - { "4.14.26", "Invalid IDP with indirectCRL Test26", 44 }, - { "4.14.27", "Invalid cRLIssuer Test27", 3 }, - { "4.14.28", "Valid cRLIssuer Test28", ok}, - { "4.14.29", "Valid cRLIssuer Test29", ok}, - - %% Although this test is valid it has a circular dependency. As a result - %% an attempt is made to reursively checks a CRL path and rejected due to - %% a CRL path validation error. PKITS notes suggest this test does not - %% need to be run due to this issue. - { "4.14.30", "Valid cRLIssuer Test30", 54 }, - { "4.14.31", "Invalid cRLIssuer Test31", 23 }, - { "4.14.32", "Invalid cRLIssuer Test32", 23 }, - { "4.14.33", "Valid cRLIssuer Test33", ok}, - { "4.14.34", "Invalid cRLIssuer Test34", 23 }, - { "4.14.35", "Invalid cRLIssuer Test35", 44 }]. -delta_crls() -> - %%{ "4.15", "Delta-CRLs" }, - [{ "4.15.1", "Invalid deltaCRLIndicator No Base Test1", 3 }, - { "4.15.2", "Valid delta-CRL Test2", ok}, - { "4.15.3", "Invalid delta-CRL Test3", 23 }, - { "4.15.4", "Invalid delta-CRL Test4", 23 }, - { "4.15.5", "Valid delta-CRL Test5", ok}, - { "4.15.6", "Invalid delta-CRL Test6", 23 }, - { "4.15.7", "Valid delta-CRL Test7", ok}, - { "4.15.8", "Valid delta-CRL Test8", ok}, - { "4.15.9", "Invalid delta-CRL Test9", 23 }, - { "4.15.10", "Invalid delta-CRL Test10", 12 }]. -private_certificate_extensions() -> - %%{ "4.16", "Private Certificate Extensions" }, - [{ "4.16.1", "Valid Unknown Not Critical Certificate Extension Test1", ok}, - { "4.16.2", "Invalid Unknown Critical Certificate Extension Test2", - {bad_cert,unknown_critical_extension}}]. - - -convert() -> - Tests = [signature_verification(), - validity_periods(), - verifying_name_chaining(), - basic_certificate_revocation_tests(), - verifying_paths_with_self_issued_certificates(), - verifying_basic_constraints(), - key_usage(), - certificate_policies(), - require_explicit_policy(), - policy_mappings(), - inhibit_policy_mapping(), - inhibit_any_policy(), - name_constraints(), - distribution_points(), - delta_crls(), - private_certificate_extensions()], - [convert(Test) || Test <- lists:flatten(Tests)]. - -convert({_,Test,_}) -> - convert1(Test); -convert({_,Test,_,_,_,_,_}) -> - convert1(Test). - -convert1(Test) -> - FName = lists:append(string:tokens(Test, " -")), - File = filename:join(?MIME, "Signed" ++ FName ++ ".eml"), - io:format("Convert ~p~n",[File]), - {ok, Mail} = file:read_file(File), - Base64 = skip_lines(Mail), - %%io:format("~s",[Base64]), - Tmp = base64:mime_decode(Base64), - file:write_file("pkits/smime-pem/tmp-pkcs7.der", Tmp), - Cmd = "openssl pkcs7 -inform der -in pkits/smime-pem/tmp-pkcs7.der" - " -print_certs -out pkits/smime-pem/" ++ FName ++ ".pem", - case os:cmd(Cmd) of - "" -> ok; - Err -> - io:format("~s",[Err]), - erlang:error(bad_cmd) - end. - -skip_lines(<<"\r\n\r\n", Rest/binary>>) -> Rest; -skip_lines(<<"\n\n", Rest/binary>>) -> Rest; -skip_lines(<<_:8, Rest/binary>>) -> - skip_lines(Rest). - -init_per_testcase(_Func, Config) -> - Datadir = proplists:get_value(data_dir, Config), - put(datadir, Datadir), - Config. - -end_per_testcase(_Func, Config) -> - %% Nodes = select_nodes(all, Config, ?FILE, ?LINE), - %% rpc:multicall(Nodes, mnesia, lkill, []), - Config. - -init_per_suite(Config) -> - try crypto:start() of - ok -> - Config - catch _:_ -> - {skip, "Crypto did not start"} - end. - -end_per_suite(_Config) -> - application:stop(crypto). - -error(Format, Args, File0, Line) -> - File = filename:basename(File0), - Pid = group_leader(), - Pid ! {failed, File, Line}, - io:format(Pid, "~s(~p): ERROR"++Format, [File,Line|Args]). - -warning(Format, Args, File0, Line) -> - File = filename:basename(File0), - io:format("~s(~p): Warning "++Format, [File,Line|Args]). diff --git a/lib/public_key/vsn.mk b/lib/public_key/vsn.mk index c99fd6fee1..3c6b012152 100644 --- a/lib/public_key/vsn.mk +++ b/lib/public_key/vsn.mk @@ -1 +1 @@ -PUBLIC_KEY_VSN = 0.11 +PUBLIC_KEY_VSN = 0.12 diff --git a/lib/ssh/doc/src/notes.xml b/lib/ssh/doc/src/notes.xml index af667b1a71..224b9d4af7 100644 --- a/lib/ssh/doc/src/notes.xml +++ b/lib/ssh/doc/src/notes.xml @@ -29,6 +29,19 @@ <file>notes.xml</file> </header> +<section><title>Ssh 2.0.5</title> + <section><title>Improvements and New Features</title> + <list> + <item> + <p> + Strengthened random number generation. (Thanks to Geoff Cant)</p> + <p> + Own Id: OTP-9225</p> + </item> + </list> + </section> +</section> + <section><title>Ssh 2.0.4</title> <section><title>Fixed Bugs and Malfunctions</title> <list> diff --git a/lib/ssh/src/ssh.appup.src b/lib/ssh/src/ssh.appup.src index 501da8ceb9..9be8c3c7d5 100644 --- a/lib/ssh/src/ssh.appup.src +++ b/lib/ssh/src/ssh.appup.src @@ -19,34 +19,44 @@ {"%VSN%", [ - {"2.0.3", [{load_module, ssh_file, soft_purge, soft_purge, []}, + {"2.0.4", [{load_module, ssh_bits, soft_purge, soft_purge, []}, + {load_module, ssh_connection_handler, soft_purge, soft_purge, []}]}, + {"2.0.3", [{load_module, ssh_bits, soft_purge, soft_purge, []}, + {load_module, ssh_connection_handler, soft_purge, soft_purge, []}, + {load_module, ssh_file, soft_purge, soft_purge, []}, {load_module, ssh, soft_purge, soft_purge, []}, {load_module, ssh_rsa, soft_purge, soft_purge, []}, {load_module, ssh_acceptor, soft_purge, soft_purge, []}, {load_module, ssh_transport, soft_purge, soft_purge, []}, {load_module, ssh_connection_manager, soft_purge, soft_purge, []}]}, - {"2.0.2", [{load_module, ssh_file, soft_purge, soft_purge, []}, + {"2.0.2", [{load_module, ssh_bits, soft_purge, soft_purge, []}, + {load_module, ssh_connection_handler, soft_purge, soft_purge, []}, + {load_module, ssh_file, soft_purge, soft_purge, []}, {load_module, ssh, soft_purge, soft_purge, []}, {load_module, ssh_rsa, soft_purge, soft_purge, []}, {load_module, ssh_acceptor, soft_purge, soft_purge, []}, {load_module, ssh_transport, soft_purge, soft_purge, []}, - {load_module, ssh_connection_manager, soft_purge, soft_purge, []}]}, - {"2.0.1", [{restart_application, ssh}]} + {load_module, ssh_connection_manager, soft_purge, soft_purge, []}]} ], [ - {"2.0.3", [{load_module, ssh_file, soft_purge, soft_purge, []}, + {"2.0.4", [{load_module, ssh_bits, soft_purge, soft_purge, []}, + {load_module, ssh_connection_handler, soft_purge, soft_purge, []}]}, + {"2.0.3", [{load_module, ssh_bits, soft_purge, soft_purge, []}, + {load_module, ssh_connection_handler, soft_purge, soft_purge, []}, + {load_module, ssh_file, soft_purge, soft_purge, []}, {load_module, ssh, soft_purge, soft_purge, []}, {load_module, ssh_rsa, soft_purge, soft_purge, []}, {load_module, ssh_acceptor, soft_purge, soft_purge, []}, {load_module, ssh_transport, soft_purge, soft_purge, []}, {load_module, ssh_connection_manager, soft_purge, soft_purge, []}]}, - {"2.0.2", [{load_module, ssh_file, soft_purge, soft_purge, []}, + {"2.0.2", [{load_module, ssh_bits, soft_purge, soft_purge, []}, + {load_module, ssh_connection_handler, soft_purge, soft_purge, []}, + {load_module, ssh_file, soft_purge, soft_purge, []}, {load_module, ssh, soft_purge, soft_purge, []}, {load_module, ssh_rsa, soft_purge, soft_purge, []}, {load_module, ssh_acceptor, soft_purge, soft_purge, []}, {load_module, ssh_transport, soft_purge, soft_purge, []}, - {load_module, ssh_connection_manager, soft_purge, soft_purge, []}]}, - {"2.0.1", [{restart_application, ssh}]} + {load_module, ssh_connection_manager, soft_purge, soft_purge, []}]} ] }. diff --git a/lib/ssh/src/ssh_bits.erl b/lib/ssh/src/ssh_bits.erl index 399581a0fd..3f0a06575c 100755 --- a/lib/ssh/src/ssh_bits.erl +++ b/lib/ssh/src/ssh_bits.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2005-2010. All Rights Reserved. +%% Copyright Ericsson AB 2005-2011. All Rights Reserved. %% %% The contents of this file are subject to the Erlang Public License, %% Version 1.1, (the "License"); you may not use this file except in @@ -34,7 +34,7 @@ %% integer utils -export([isize/1]). -export([irandom/1, irandom/3]). --export([random/1, random/3]). +-export([random/1]). -export([xor_bits/2, fill_bits/2]). -export([i2bin/2, bin2i/1]). @@ -401,9 +401,6 @@ xor_bits(XBits, YBits) -> irandom(Bits) -> irandom(Bits, 1, 0). -%% irandom_odd(Bits) -> -%% irandom(Bits, 1, 1). - %% %% irandom(N, Top, Bottom) %% @@ -414,57 +411,16 @@ irandom(Bits) -> %% Bot = 0 - do not set the least signifcant bit %% Bot = 1 - set the least signifcant bit (i.e always odd) %% -irandom(0, _Top, _Bottom) -> - 0; -irandom(Bits, Top, Bottom) -> - Bytes = (Bits+7) div 8, - Skip = (8-(Bits rem 8)) rem 8, - TMask = case Top of - 0 -> 0; - 1 -> 16#80; - 2 -> 16#c0 - end, - BMask = case Bottom of - 0 -> 0; - 1 -> (1 bsl Skip) - end, - <<X:Bits/big-unsigned-integer, _:Skip>> = random(Bytes, TMask, BMask), - X. +irandom(Bits, Top, Bottom) when is_integer(Top), + 0 =< Top, Top =< 2 -> + crypto:erlint(crypto:strong_rand_mpint(Bits, Top - 1, Bottom)). %% %% random/1 %% Generate N random bytes %% random(N) -> - random(N, 0, 0). - -random(N, TMask, BMask) -> - list_to_binary(rnd(N, TMask, BMask)). - -%% random/3 -%% random(Bytes, TopMask, BotMask) -%% where -%% Bytes is the number of bytes to generate -%% TopMask is bitwised or'ed to the first byte -%% BotMask is bitwised or'ed to the last byte -%% -rnd(0, _TMask, _BMask) -> - []; -rnd(1, TMask, BMask) -> - [(rand8() bor TMask) bor BMask]; -rnd(N, TMask, BMask) -> - [(rand8() bor TMask) | rnd_n(N-1, BMask)]. - -rnd_n(1, BMask) -> - [rand8() bor BMask]; -rnd_n(I, BMask) -> - [rand8() | rnd_n(I-1, BMask)]. - -rand8() -> - (rand32() bsr 8) band 16#ff. - -rand32() -> - random:uniform(16#100000000) -1. + crypto:strong_rand_bytes(N). %% %% Base 64 encode/decode diff --git a/lib/ssh/src/ssh_connection_handler.erl b/lib/ssh/src/ssh_connection_handler.erl index 0ba11b0a26..2d82e6d77d 100644 --- a/lib/ssh/src/ssh_connection_handler.erl +++ b/lib/ssh/src/ssh_connection_handler.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2008-2010. All Rights Reserved. +%% Copyright Ericsson AB 2008-2011. All Rights Reserved. %% %% The contents of this file are subject to the Erlang Public License, %% Version 1.1, (the "License"); you may not use this file except in @@ -106,8 +106,6 @@ peer_address(ConnectionHandler) -> %% initialize. %%-------------------------------------------------------------------- init([Role, Manager, Socket, SshOpts]) -> - {A,B,C} = erlang:now(), - random:seed(A, B, C), {NumVsn, StrVsn} = ssh_transport:versions(Role, SshOpts), ssh_bits:install_messages(ssh_transport:transport_messages(NumVsn)), {Protocol, Callback, CloseTag} = diff --git a/lib/ssh/vsn.mk b/lib/ssh/vsn.mk index 51f9f47446..8c9f671fd5 100644 --- a/lib/ssh/vsn.mk +++ b/lib/ssh/vsn.mk @@ -1,5 +1,5 @@ #-*-makefile-*- ; force emacs to enter makefile-mode -SSH_VSN = 2.0.4 +SSH_VSN = 2.0.5 APP_VSN = "ssh-$(SSH_VSN)" diff --git a/lib/ssl/doc/src/ssl.xml b/lib/ssl/doc/src/ssl.xml index cd5c9281cd..60ea4d547f 100644 --- a/lib/ssl/doc/src/ssl.xml +++ b/lib/ssl/doc/src/ssl.xml @@ -266,7 +266,7 @@ fun(OtpCert :: #'OTPCertificate'{}, Event :: {bad_cert, Reason :: atom()} | <p>Possible path validation errors: </p> -<p> {bad_cert, cert_expired}, {bad_cert, invalid_issuer}, {bad_cert, invalid_signature}, {bad_cert, unknown_ca}, {bad_cert, name_not_permitted}, {bad_cert, missing_basic_constraint}, {bad_cert, invalid_key_usage}</p> +<p> {bad_cert, cert_expired}, {bad_cert, invalid_issuer}, {bad_cert, invalid_signature}, {bad_cert, unknown_ca},{bad_cert, selfsigned_peer}, {bad_cert, name_not_permitted}, {bad_cert, missing_basic_constraint}, {bad_cert, invalid_key_usage}</p> </item> <tag>{hibernate_after, integer()|undefined}</tag> diff --git a/lib/ssl/src/ssl.appup.src b/lib/ssl/src/ssl.appup.src index d3e426f254..a0ecb4ac6f 100644 --- a/lib/ssl/src/ssl.appup.src +++ b/lib/ssl/src/ssl.appup.src @@ -1,6 +1,7 @@ %% -*- erlang -*- {"%VSN%", [ + {"4.1.4", [{restart_application, ssl}]}, {"4.1.3", [{restart_application, ssl}]}, {"4.1.2", [{restart_application, ssl}]}, {"4.1.1", [{restart_application, ssl}]}, @@ -8,6 +9,7 @@ {"4.0.1", [{restart_application, ssl}]} ], [ + {"4.1.4", [{restart_application, ssl}]}, {"4.1.3", [{restart_application, ssl}]}, {"4.1.2", [{restart_application, ssl}]}, {"4.1.1", [{restart_application, ssl}]}, diff --git a/lib/ssl/vsn.mk b/lib/ssl/vsn.mk index 2f1edfa186..0e80e42637 100644 --- a/lib/ssl/vsn.mk +++ b/lib/ssl/vsn.mk @@ -1 +1 @@ -SSL_VSN = 4.1.4 +SSL_VSN = 4.1.5 diff --git a/lib/stdlib/doc/src/supervisor.xml b/lib/stdlib/doc/src/supervisor.xml index 45fa0847a8..d6203bdaa0 100644 --- a/lib/stdlib/doc/src/supervisor.xml +++ b/lib/stdlib/doc/src/supervisor.xml @@ -4,7 +4,7 @@ <erlref> <header> <copyright> - <year>1996</year><year>2010</year> + <year>1996</year><year>2011</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -83,11 +83,17 @@ supervisor, where all child processes are dynamically added instances of the same process type, i.e. running the same code.</p> - <p>The functions <c>terminate_child/2</c>, <c>delete_child/2</c> + <p>The functions <c>delete_child/2</c> and <c>restart_child/2</c> are invalid for <c>simple_one_for_one</c> supervisors and will return <c>{error,simple_one_for_one}</c> if the specified supervisor uses this restart strategy.</p> + <p>The function <c>terminate_child/2</c> can be used for + children under <c>simple_one_for_one</c> supervisors by + giving the child's <c>pid()</c> as the second argument. If + instead the child specification identifier is used, + <c>terminate_child/2</c> will return + <c>{error,simple_one_for_one}</c>.</p> </item> </list> <p>To prevent a supervisor from getting into an infinite loop of @@ -311,24 +317,33 @@ child_spec() = {Id,StartFunc,Restart,Shutdown,Type,Modules} <type> <v>SupRef = Name | {Name,Node} | {global,Name} | pid()</v> <v> Name = Node = atom()</v> - <v>Id = term()</v> + <v>Id = pid() | term()</v> <v>Result = ok | {error,Error}</v> <v> Error = not_found | simple_one_for_one</v> </type> <desc> - <p>Tells the supervisor <c>SupRef</c> to terminate the child - process corresponding to the child specification identified - by <c>Id</c>. The process, if there is one, is terminated but - the child specification is kept by the supervisor. This means - that the child process may be later be restarted by - the supervisor. The child process can also be restarted - explicitly by calling <c>restart_child/2</c>. Use - <c>delete_child/2</c> to remove the child specification.</p> + <p>Tells the supervisor <c>SupRef</c> to terminate the given + child.</p> + <p>If the supervisor is not <c>simple_one_for_one</c>, + <c>Id</c> must be the child specification identifier. The + process, if there is one, is terminated but the child + specification is kept by the supervisor. The child process + may later be restarted by the supervisor. The child process + can also be restarted explicitly by calling + <c>restart_child/2</c>. Use <c>delete_child/2</c> to remove + the child specification.</p> + <p>If the supervisor is <c>simple_one_for_one</c>, <c>Id</c> + must be the child process' <c>pid()</c>. I the specified + process is alive, but is not a child of the given + supervisor, the function will return + <c>{error,not_found}</c>. If the child specification + identifier is given instead instead of a <c>pid()</c>, the + function will return <c>{error,simple_one_for_one}</c>.</p> + <p>If successful, the function returns <c>ok</c>. If there is + no child specification with the specified <c>Id</c>, the + function returns <c>{error,not_found}</c>.</p> <p>See <c>start_child/2</c> for a description of <c>SupRef</c>.</p> - <p>If successful, the function returns <c>ok</c>. If there is - no child specification with the specified <c>Id</c>, - the function returns <c>{error,not_found}</c>.</p> </desc> </func> <func> diff --git a/lib/stdlib/src/pool.erl b/lib/stdlib/src/pool.erl index 7f5f23e26d..a3c9927ee9 100644 --- a/lib/stdlib/src/pool.erl +++ b/lib/stdlib/src/pool.erl @@ -95,6 +95,9 @@ pspawn_link(M, F, A) -> start_nodes([], _, _) -> []; start_nodes([Host|Tail], Name, Args) -> case slave:start(Host, Name, Args) of + {error, {already_running, Node}} -> + io:format("Can't start node on host ~w due to ~w~n",[Host, {already_running, Node}]), + [Node | start_nodes(Tail, Name, Args)]; {error, R} -> io:format("Can't start node on host ~w due to ~w~n",[Host, R]), start_nodes(Tail, Name, Args); diff --git a/lib/stdlib/src/supervisor.erl b/lib/stdlib/src/supervisor.erl index 368dc2e3e5..4fd7f1d47c 100644 --- a/lib/stdlib/src/supervisor.erl +++ b/lib/stdlib/src/supervisor.erl @@ -138,7 +138,7 @@ delete_child(Supervisor, Name) -> %%----------------------------------------------------------------- -type term_err() :: 'not_found' | 'simple_one_for_one'. --spec terminate_child(sup_ref(), term()) -> 'ok' | {'error', term_err()}. +-spec terminate_child(sup_ref(), pid() | term()) -> 'ok' | {'error', term_err()}. terminate_child(Supervisor, Name) -> call(Supervisor, {terminate_child, Name}). @@ -297,8 +297,26 @@ handle_call({start_child, EArgs}, _From, State) when ?is_simple(State) -> {reply, What, State} end; -%%% The requests terminate_child, delete_child and restart_child are -%%% invalid for simple_one_for_one supervisors. +%% terminate_child for simple_one_for_one can only be done with pid +handle_call({terminate_child, Name}, _From, State) when not is_pid(Name), + ?is_simple(State) -> + {reply, {error, simple_one_for_one}, State}; + +handle_call({terminate_child, Name}, _From, State) -> + case get_child(Name, State, ?is_simple(State)) of + {value, Child} -> + case do_terminate(Child, State#state.name) of + #child{restart_type=RT} when RT=:=temporary; ?is_simple(State) -> + {reply, ok, state_del_child(Child, State)}; + NChild -> + {reply, ok, replace_child(NChild, State)} + end; + false -> + {reply, {error, not_found}, State} + end; + +%%% The requests delete_child and restart_child are invalid for +%%% simple_one_for_one supervisors. handle_call({_Req, _Data}, _From, State) when ?is_simple(State) -> {reply, {error, simple_one_for_one}, State}; @@ -341,19 +359,6 @@ handle_call({delete_child, Name}, _From, State) -> {reply, {error, not_found}, State} end; -handle_call({terminate_child, Name}, _From, State) -> - case get_child(Name, State) of - {value, Child} -> - case do_terminate(Child, State#state.name) of - #child{restart_type = temporary} = NChild -> - {reply, ok, state_del_child(NChild, State)}; - NChild -> - {reply, ok, replace_child(NChild, State)} - end; - _ -> - {reply, {error, not_found}, State} - end; - handle_call(which_children, _From, #state{children = [#child{restart_type = temporary, child_type = CT, modules = Mods}]} = @@ -849,7 +854,28 @@ split_child(_, [], After) -> {lists:reverse(After), []}. get_child(Name, State) -> + get_child(Name, State, false). +get_child(Pid, State, AllowPid) when AllowPid, is_pid(Pid) -> + get_dynamic_child(Pid, State); +get_child(Name, State, _) -> lists:keysearch(Name, #child.name, State#state.children). + +get_dynamic_child(Pid, #state{children=[Child], dynamics=Dynamics}) -> + case is_dynamic_pid(Pid, dynamics_db(Child#child.restart_type, Dynamics)) of + true -> + {value, Child#child{pid=Pid}}; + false -> + case erlang:is_process_alive(Pid) of + true -> false; + false -> {value, Child} + end + end. + +is_dynamic_pid(Pid, Dynamics) when is_list(Dynamics) -> + lists:member(Pid, Dynamics); +is_dynamic_pid(Pid, Dynamics) -> + dict:is_key(Pid, Dynamics). + replace_child(Child, State) -> Chs = do_replace_child(Child, State#state.children), State#state{children = Chs}. diff --git a/lib/stdlib/test/supervisor_SUITE.erl b/lib/stdlib/test/supervisor_SUITE.erl index f9ceed8f84..cc271bd047 100644 --- a/lib/stdlib/test/supervisor_SUITE.erl +++ b/lib/stdlib/test/supervisor_SUITE.erl @@ -20,7 +20,7 @@ -module(supervisor_SUITE). --include_lib("test_server/include/test_server.hrl"). +-include_lib("common_test/include/ct.hrl"). -define(TIMEOUT, 1000). %% Testserver specific export @@ -349,8 +349,7 @@ child_adm(Config) when is_list(Config) -> ok = supervisor:terminate_child(sup_test, child1), %% Start of already existing but not running process - {error,already_present} = - supervisor:start_child(sup_test, Child), + {error,already_present} = supervisor:start_child(sup_test, Child), %% Restart {ok, CPid2} = supervisor:restart_child(sup_test, child1), @@ -377,6 +376,11 @@ child_adm(Config) when is_list(Config) -> [{child1, CPid3, worker, []}] = supervisor:which_children(sup_test), [1,1,0,1] = get_child_counts(sup_test), + %% Terminate with Pid not allowed when not simple_one_for_one + {error,not_found} = supervisor:terminate_child(sup_test, CPid3), + [{child1, CPid3, worker, []}] = supervisor:which_children(sup_test), + [1,1,0,1] = get_child_counts(sup_test), + {'EXIT',{noproc,{gen_server,call,[foo,which_children,infinity]}}} = (catch supervisor:which_children(foo)), {'EXIT',{noproc,{gen_server,call,[foo,count_children,infinity]}}} @@ -412,16 +416,26 @@ child_adm_simple(Config) when is_list(Config) -> [1,2,0,2] = get_child_counts(sup_test), %% Termination - {error, simple_one_for_one} = - supervisor:terminate_child(sup_test, child1), + {error, simple_one_for_one} = supervisor:terminate_child(sup_test, child1), + [1,2,0,2] = get_child_counts(sup_test), + ok = supervisor:terminate_child(sup_test,CPid1), + [_] = supervisor:which_children(sup_test), + [1,1,0,1] = get_child_counts(sup_test), + false = erlang:is_process_alive(CPid1), + %% Terminate non-existing proccess is ok + ok = supervisor:terminate_child(sup_test,CPid1), + [_] = supervisor:which_children(sup_test), + [1,1,0,1] = get_child_counts(sup_test), + %% Terminate pid which is not a child of this supervisor is not ok + NoChildPid = spawn_link(fun() -> receive after infinity -> ok end end), + {error, not_found} = supervisor:terminate_child(sup_test, NoChildPid), + true = erlang:is_process_alive(NoChildPid), %% Restart - {error, simple_one_for_one} = - supervisor:restart_child(sup_test, child1), + {error, simple_one_for_one} = supervisor:restart_child(sup_test, child1), %% Deletion - {error, simple_one_for_one} = - supervisor:delete_child(sup_test, child1), + {error, simple_one_for_one} = supervisor:delete_child(sup_test, child1), ok. %%------------------------------------------------------------------------- diff --git a/lib/test_server/src/test_server.erl b/lib/test_server/src/test_server.erl index 7f0011bd68..8fe7d72270 100644 --- a/lib/test_server/src/test_server.erl +++ b/lib/test_server/src/test_server.erl @@ -1193,11 +1193,10 @@ run_test_case_eval1(Mod, Func, Args, Name, RunInit, TCCallback) -> do_end_tc_call(M,F,Res,Return) -> Ref = make_ref(), - case test_server_sup:framework_call( - end_tc, [?pl2a(M),F,Res], Ref) of - {fail,FWReason} -> - {failed,FWReason}; - Ref -> + case os:getenv("TEST_SERVER_FRAMEWORK") of + FW when FW == "ct_framework"; + FW == "undefined"; + FW == false -> case test_server_sup:framework_call( end_tc, [?pl2a(M),F,Res, Return], ok) of {fail,FWReason} -> @@ -1212,8 +1211,14 @@ do_end_tc_call(M,F,Res,Return) -> NewReturn -> NewReturn end; - _ -> - Return + Other -> + case test_server_sup:framework_call( + end_tc, [Other,F,Res], Ref) of + {fail,FWReason} -> + {failed,FWReason}; + _Else -> + Return + end end. %% the return value is a list and we have to check if it contains diff --git a/system/doc/design_principles/sup_princ.xml b/system/doc/design_principles/sup_princ.xml index 067fd31961..2748f21bbe 100644 --- a/system/doc/design_principles/sup_princ.xml +++ b/system/doc/design_principles/sup_princ.xml @@ -4,7 +4,7 @@ <chapter> <header> <copyright> - <year>1997</year><year>2009</year> + <year>1997</year><year>2011</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -335,6 +335,12 @@ supervisor:start_child(Pid, [id1])</code> <c>apply(call, start_link, []++[id1])</c>, or actually:</p> <code type="none"> call:start_link(id1)</code> + <p>A child under a <c>simple_one_for_one</c> supervisor can be terminated + with</p> + <code type="none"> +supervisor:terminate_child(Sup, Pid)</code> + <p>where <c>Sup</c> is the pid, or name, of the supervisor and + <c>Pid</c> is the pid of the child.</p> </section> <section> |