diff options
125 files changed, 6577 insertions, 4644 deletions
diff --git a/.gitignore b/.gitignore index 7ccedd3ff3..9cd91245f5 100644 --- a/.gitignore +++ b/.gitignore @@ -150,6 +150,7 @@ JAVADOC-GENERATED /erts/epmd/test/Emakefile /lib/*/SKIP +/lib/SKIP-APPLICATIONS /lib/*/doc/html/*.html /lib/*/doc/html/*.css diff --git a/HOWTO/INSTALL-CROSS.md b/HOWTO/INSTALL-CROSS.md index fbcb5f83c6..a5cf775583 100644 --- a/HOWTO/INSTALL-CROSS.md +++ b/HOWTO/INSTALL-CROSS.md @@ -4,14 +4,7 @@ Cross Compiling Erlang/OTP Introduction ------------ -This document describes how to cross compile Erlang/OTP-%OTP-REL%. Note that -the support for cross compiling Erlang/OTP should be considered as -experimental. As far as we know, the %OTP-REL% release should cross compile -fine, but since we currently have a very limited set of cross compilation -environments to test with we cannot be sure. The cross compilation support -will remain in an experimental state until we get a lot more cross compilation -environments to test with. - +This document describes how to cross compile Erlang/OTP-%OTP-REL%. You are advised to read the whole document before attempting to cross compile Erlang/OTP. However, before reading this document, you should read the [$ERL_TOP/HOWTO/INSTALL.md][] document which describes building and installing diff --git a/HOWTO/INSTALL.md b/HOWTO/INSTALL.md index fa1b9d2e89..5bde47e1f6 100644 --- a/HOWTO/INSTALL.md +++ b/HOWTO/INSTALL.md @@ -296,6 +296,12 @@ Some of the available `configure` options are: you can build using a fallback implementation based on mutexes or spinlocks. Performance of the SMP runtime system will however suffer immensely without an implementation for native atomic memory accesses. +* `--without-$app` - By default all applications in Erlang/OTP will be included + in a release. If this is not wanted it is possible to specify that Erlang/OTP + should be compiled without that applications, i.e. `--without-wx`. There is + no automatic dependency handling inbetween applications. So if you disable + an application that another depends on, you also have to disable the + dependant application. If you or your system has special requirements please read the `Makefile` for additional configuration information. diff --git a/bootstrap/lib/stdlib/ebin/erl_lint.beam b/bootstrap/lib/stdlib/ebin/erl_lint.beam Binary files differindex ee07e7636c..30c387c53c 100644 --- a/bootstrap/lib/stdlib/ebin/erl_lint.beam +++ b/bootstrap/lib/stdlib/ebin/erl_lint.beam diff --git a/configure.in b/configure.in index 4b3884864c..f25a068be9 100644 --- a/configure.in +++ b/configure.in @@ -390,6 +390,15 @@ if test X${enable_native_libs} = Xyes -a X${enable_hipe} != Xno; then fi AC_SUBST(NATIVE_LIBS_ENABLED) + +rm -f $ERL_TOP/lib/SKIP-APPLICATIONS +for app in `cd lib && ls -d *`; do + var=`eval echo \\$with_$app` + if test X${var} == Xno; then + echo "$app" >> $ERL_TOP/lib/SKIP-APPLICATIONS + fi +done + export ERL_TOP AC_CONFIG_SUBDIRS(lib erts) @@ -400,15 +409,22 @@ AC_OUTPUT pattern="lib/*/SKIP" files=`echo $pattern` -if test "$files" != "$pattern"; then +if test "$files" != "$pattern" || test -f $ERL_TOP/lib/SKIP-APPLICATIONS; then echo '*********************************************************************' echo '********************** APPLICATIONS DISABLED **********************' echo '*********************************************************************' echo - for skipfile in $files; do - app=`dirname $skipfile`; app=`basename $app` - printf "%-15s: " $app; cat $skipfile - done + if test "$files" != "$pattern"; then + for skipfile in $files; do + app=`dirname $skipfile`; app=`basename $app` + printf "%-15s: " $app; cat $skipfile + done + fi + if test -f $ERL_TOP/lib/SKIP-APPLICATIONS; then + for skipapp in `cat $ERL_TOP/lib/SKIP-APPLICATIONS`; do + printf "%-15s: User gave --without-%s option\n" $skipapp $skipapp + done + fi echo echo '*********************************************************************' fi diff --git a/erts/configure.in b/erts/configure.in index 64436e933c..00c7045ea2 100644 --- a/erts/configure.in +++ b/erts/configure.in @@ -1679,6 +1679,10 @@ if test x"$ac_cv_header_netinet_sctp_h" = x"yes"; then ]) fi +dnl Check for setns +AC_CHECK_HEADERS(sched.h setns.h) +AC_CHECK_FUNCS([setns]) + HAVE_VALGRIND=no AC_CHECK_HEADER(valgrind/valgrind.h, HAVE_VALGRIND=yes) AC_SUBST(HAVE_VALGRIND) diff --git a/erts/doc/src/erl_driver.xml b/erts/doc/src/erl_driver.xml index 540390e1b1..c055d1ca9e 100644 --- a/erts/doc/src/erl_driver.xml +++ b/erts/doc/src/erl_driver.xml @@ -2907,8 +2907,84 @@ ERL_DRV_EXT2TERM char *buf, ErlDrvUInt len beginning of this document.</p> </desc> </func> - </funcs> + <func> + <name><ret>char *</ret><nametext>erl_drv_cond_name(ErlDrvCond *cnd)</nametext></name> + <fsummary>Get name of driver mutex.</fsummary> + <desc> + <marker id="erl_drv_cnd_name"></marker> + <p>Arguments:</p> + <taglist> + <tag><c>cnd</c></tag> + <item>A pointer to an initialized condition.</item> + </taglist> + <p> + Returns a pointer to the name of the condition. + </p> + <note> + <p>This function is intended for debugging purposes only.</p> + </note> + </desc> + </func> + + <func> + <name><ret>char *</ret><nametext>erl_drv_mutex_name(ErlDrvMutex *mtx)</nametext></name> + <fsummary>Get name of driver mutex.</fsummary> + <desc> + <marker id="erl_drv_mutex_name"></marker> + <p>Arguments:</p> + <taglist> + <tag><c>mtx</c></tag> + <item>A pointer to an initialized mutex.</item> + </taglist> + <p> + Returns a pointer to the name of the mutex. + </p> + <note> + <p>This function is intended for debugging purposes only.</p> + </note> + </desc> + </func> + + <func> + <name><ret>char *</ret><nametext>erl_drv_rwlock_name(ErlDrvRWLock *rwlck)</nametext></name> + <fsummary>Get name of driver mutex.</fsummary> + <desc> + <marker id="erl_drv_rwlock_name"></marker> + <p>Arguments:</p> + <taglist> + <tag><c>rwlck</c></tag> + <item>A pointer to an initialized r/w-lock.</item> + </taglist> + <p> + Returns a pointer to the name of the r/w-lock. + </p> + <note> + <p>This function is intended for debugging purposes only.</p> + </note> + </desc> + </func> + + <func> + <name><ret>char *</ret><nametext>erl_drv_thread_name(ErlDrvTid tid)</nametext></name> + <fsummary>Get name of driver mutex.</fsummary> + <desc> + <marker id="erl_drv_rwlock_name"></marker> + <p>Arguments:</p> + <taglist> + <tag><c>tid</c></tag> + <item>A thread identifier.</item> + </taglist> + <p> + Returns a pointer to the name of the thread. + </p> + <note> + <p>This function is intended for debugging purposes only.</p> + </note> + </desc> + </func> + + </funcs> <section> <title>SEE ALSO</title> <p><seealso marker="driver_entry">driver_entry(3)</seealso>, diff --git a/erts/emulator/beam/erl_driver.h b/erts/emulator/beam/erl_driver.h index 1ab6e17f56..b68fd46fcc 100644 --- a/erts/emulator/beam/erl_driver.h +++ b/erts/emulator/beam/erl_driver.h @@ -546,6 +546,11 @@ EXTERN int erl_drv_equal_tids(ErlDrvTid tid1, ErlDrvTid tid2); EXTERN void erl_drv_thread_exit(void *resp); EXTERN int erl_drv_thread_join(ErlDrvTid, void **respp); +EXTERN char* erl_drv_mutex_name(ErlDrvMutex *mtx); +EXTERN char* erl_drv_cond_name(ErlDrvCond *cnd); +EXTERN char* erl_drv_rwlock_name(ErlDrvRWLock *rwlck); +EXTERN char* erl_drv_thread_name(ErlDrvTid tid); + /* * Misc. */ @@ -683,6 +688,3 @@ EXTERN int erl_drv_getenv(char *key, char *value, size_t *value_size); /* also in global.h, but driver's can't include global.h */ void dtrace_drvport_str(ErlDrvPort port, char *port_buf); - - - diff --git a/erts/emulator/beam/erl_drv_thread.c b/erts/emulator/beam/erl_drv_thread.c index a49a155701..4f1bba8657 100644 --- a/erts/emulator/beam/erl_drv_thread.c +++ b/erts/emulator/beam/erl_drv_thread.c @@ -188,6 +188,17 @@ erl_drv_mutex_destroy(ErlDrvMutex *dmtx) #endif } + +char * +erl_drv_mutex_name(ErlDrvMutex *dmtx) +{ +#ifdef USE_THREADS + return dmtx ? dmtx->name : NULL; +#else + return NULL; +#endif +} + int erl_drv_mutex_trylock(ErlDrvMutex *dmtx) { @@ -258,6 +269,15 @@ erl_drv_cond_destroy(ErlDrvCond *dcnd) #endif } +char * +erl_drv_cond_name(ErlDrvCond *dcnd) +{ +#ifdef USE_THREADS + return dcnd ? dcnd->name : NULL; +#else + return NULL; +#endif +} void erl_drv_cond_signal(ErlDrvCond *dcnd) @@ -331,6 +351,16 @@ erl_drv_rwlock_destroy(ErlDrvRWLock *drwlck) #endif } +char * +erl_drv_rwlock_name(ErlDrvRWLock *drwlck) +{ +#ifdef USE_THREADS + return drwlck ? drwlck->name : NULL; +#else + return NULL; +#endif +} + int erl_drv_rwlock_tryrlock(ErlDrvRWLock *drwlck) { @@ -617,6 +647,18 @@ erl_drv_thread_create(char *name, #endif } +char * +erl_drv_thread_name(ErlDrvTid tid) +{ +#ifdef USE_THREADS + struct ErlDrvTid_ *dtid = (struct ErlDrvTid_ *) tid; + return dtid ? dtid->name : NULL; +#else + return NULL; +#endif +} + + ErlDrvTid erl_drv_thread_self(void) { diff --git a/erts/emulator/beam/erl_init.c b/erts/emulator/beam/erl_init.c index f7bfa91b54..8c4fffa75b 100644 --- a/erts/emulator/beam/erl_init.c +++ b/erts/emulator/beam/erl_init.c @@ -884,6 +884,10 @@ early_init(int *argc, char **argv) /* erts_usage(); } } +#else + /* Silence gcc warnings */ + (void)schdlrs_percentage; + (void)schdlrs_onln_percentage; #endif } diff --git a/erts/emulator/beam/erl_port_task.c b/erts/emulator/beam/erl_port_task.c index 7d53ce7152..547a42beb2 100644 --- a/erts/emulator/beam/erl_port_task.c +++ b/erts/emulator/beam/erl_port_task.c @@ -1838,6 +1838,16 @@ release_port(void *vport) { erts_port_dec_refc((Port *) vport); } + +static void +schedule_release_port(void *vport) { + Port *pp = (Port*)vport; + /* This is only used when a port release was ordered from a non-scheduler */ + erts_schedule_thr_prgr_later_op(release_port, + (void *) pp, + &pp->common.u.release); +} + #endif static void @@ -2033,10 +2043,15 @@ begin_port_cleanup(Port *pp, ErtsPortTask **execqp, int *processing_busy_q_p) * Schedule cleanup of port structure... */ #ifdef ERTS_SMP - /* Has to be more or less immediate to release any driver */ - erts_schedule_thr_prgr_later_op(release_port, - (void *) pp, - &pp->common.u.release); + /* We might not be a scheduler, eg. traceing to port we are sys_msg_dispatcher */ + if (!erts_get_scheduler_data()) { + erts_schedule_misc_aux_work(1, schedule_release_port, (void*)pp); + } else { + /* Has to be more or less immediate to release any driver */ + erts_schedule_thr_prgr_later_op(release_port, + (void *) pp, + &pp->common.u.release); + } #else pp->cleanup = 1; #endif diff --git a/erts/emulator/drivers/common/efile_drv.c b/erts/emulator/drivers/common/efile_drv.c index c997fe1bf9..8de578d8b7 100644 --- a/erts/emulator/drivers/common/efile_drv.c +++ b/erts/emulator/drivers/common/efile_drv.c @@ -542,84 +542,84 @@ static void *ef_safe_realloc(void *op, Uint s) */ /* char EV_CHAR_P(ErlIOVec *ev, int p, int q) */ -#define EV_CHAR_P(ev, p, q) \ - (((char *)(ev)->iov[(q)].iov_base) + (p)) +#define EV_CHAR_P(ev, p, q) \ + (((char *)(ev)->iov[q].iov_base) + (p)) /* int EV_GET_CHAR(ErlIOVec *ev, char *p, int *pp, int *qp) */ #define EV_GET_CHAR(ev, p, pp, qp) efile_ev_get_char(ev, p ,pp, qp) static int -efile_ev_get_char(ErlIOVec *ev, char *p, int *pp, int *qp) { - if (*(pp)+1 <= (ev)->iov[*(qp)].iov_len) { - *(p) = *EV_CHAR_P(ev, *(pp), *(qp)); - if (*(pp)+1 < (ev)->iov[*(qp)].iov_len) - *(pp) = *(pp)+1; - else { - (*(qp))++; - *pp = 0; +efile_ev_get_char(ErlIOVec *ev, char *p, size_t *pp, size_t *qp) { + if (*pp + 1 <= ev->iov[*qp].iov_len) { + *p = *EV_CHAR_P(ev, *pp, *qp); + if (*pp + 1 < ev->iov[*qp].iov_len) + *pp += 1; + else { + *qp += 1; + *pp = 0; + } + return !0; } - return !0; - } - return 0; + return 0; } /* Uint32 EV_UINT32(ErlIOVec *ev, int p, int q)*/ -#define EV_UINT32(ev, p, q) \ - ((Uint32) *(((unsigned char *)(ev)->iov[(q)].iov_base) + (p))) +#define EV_UINT32(ev, p, q) \ + ((Uint32) ((unsigned char *)(ev)->iov[q].iov_base)[p]) /* int EV_GET_UINT32(ErlIOVec *ev, Uint32 *p, int *pp, int *qp) */ -#define EV_GET_UINT32(ev, p, pp, qp) efile_ev_get_uint32(ev,p,pp,qp) +#define EV_GET_UINT32(ev, p, pp, qp) efile_ev_get_uint32(ev, p, pp, qp) static int -efile_ev_get_uint32(ErlIOVec *ev, Uint32 *p, int *pp, int *qp) { - if (*(pp)+4 <= (ev)->iov[*(qp)].iov_len) { - *(p) = (EV_UINT32(ev, *(pp), *(qp)) << 24) - | (EV_UINT32(ev, *(pp)+1, *(qp)) << 16) - | (EV_UINT32(ev, *(pp)+2, *(qp)) << 8) - | (EV_UINT32(ev, *(pp)+3, *(qp))); - if (*(pp)+4 < (ev)->iov[*(qp)].iov_len) - *(pp) = *(pp)+4; - else { - (*(qp))++; - *pp = 0; +efile_ev_get_uint32(ErlIOVec *ev, Uint32 *p, size_t *pp, size_t *qp) { + if (*pp + 4 <= ev->iov[*qp].iov_len) { + *p = (EV_UINT32(ev, *pp, *qp) << 24) + | (EV_UINT32(ev, *pp + 1, *qp) << 16) + | (EV_UINT32(ev, *pp + 2, *qp) << 8) + | (EV_UINT32(ev, *pp + 3, *qp)); + if (*pp + 4 < ev->iov[*qp].iov_len) + *pp += 4; + else { + *qp += 1; + *pp = 0; + } + return !0; } - return !0; - } - return 0; + return 0; } /* Uint64 EV_UINT64(ErlIOVec *ev, int p, int q)*/ -#define EV_UINT64(ev, p, q) \ - ((Uint64) *(((unsigned char *)(ev)->iov[(q)].iov_base) + (p))) +#define EV_UINT64(ev, p, q) \ + ((Uint64) ((unsigned char *)(ev)->iov[q].iov_base)[p]) /* int EV_GET_UINT64(ErlIOVec *ev, Uint64 *p, int *pp, int *qp) */ -#define EV_GET_UINT64(ev, p, pp, qp) efile_ev_get_uint64(ev,p,pp,qp) +#define EV_GET_UINT64(ev, p, pp, qp) efile_ev_get_uint64(ev, p, pp, qp) static int -efile_ev_get_uint64(ErlIOVec *ev, Uint64 *p, int *pp, int *qp) { - if (*(pp)+8 <= (ev)->iov[*(qp)].iov_len) { - *(p) = (EV_UINT64(ev, *(pp), *(qp)) << 56) - | (EV_UINT64(ev, *(pp)+1, *(qp)) << 48) - | (EV_UINT64(ev, *(pp)+2, *(qp)) << 40) - | (EV_UINT64(ev, *(pp)+3, *(qp)) << 32) - | (EV_UINT64(ev, *(pp)+4, *(qp)) << 24) - | (EV_UINT64(ev, *(pp)+5, *(qp)) << 16) - | (EV_UINT64(ev, *(pp)+6, *(qp)) << 8) - | (EV_UINT64(ev, *(pp)+7, *(qp))); - if (*(pp)+8 < (ev)->iov[*(qp)].iov_len) - *(pp) = *(pp)+8; - else { - (*(qp))++; - *pp = 0; +efile_ev_get_uint64(ErlIOVec *ev, Uint64 *p, size_t *pp, size_t *qp) { + if (*pp + 8 <= ev->iov[*qp].iov_len) { + *p = (EV_UINT64(ev, *pp, *qp) << 56) + | (EV_UINT64(ev, *pp + 1, *qp) << 48) + | (EV_UINT64(ev, *pp + 2, *qp) << 40) + | (EV_UINT64(ev, *pp + 3, *qp) << 32) + | (EV_UINT64(ev, *pp + 4, *qp) << 24) + | (EV_UINT64(ev, *pp + 5, *qp) << 16) + | (EV_UINT64(ev, *pp + 6, *qp) << 8) + | (EV_UINT64(ev, *pp + 7, *qp)); + if (*pp + 8 < ev->iov[*qp].iov_len) + *pp += 8; + else { + *qp += 1; + *pp = 0; + } + return !0; } - return !0; - } - return 0; + return 0; } /* int EV_GET_SINT64(ErlIOVec *ev, Uint64 *p, int *pp, int *qp) */ -#define EV_GET_SINT64(ev, p, pp, qp) efile_ev_get_sint64(ev,p,pp,qp) +#define EV_GET_SINT64(ev, p, pp, qp) efile_ev_get_sint64(ev, p, pp, qp) static int -efile_ev_get_sint64(ErlIOVec *ev, Sint64 *p, int *pp, int *qp) { - Uint64 *tmp = (Uint64*)p; - return EV_GET_UINT64(ev,tmp,pp,qp); +efile_ev_get_sint64(ErlIOVec *ev, Sint64 *p, size_t *pp, size_t *qp) { + Uint64 *tmp = (Uint64*)p; + return EV_GET_UINT64(ev, tmp, pp, qp); } #if 0 @@ -1139,7 +1139,7 @@ static void invoke_read(void *data) read_size = erts_gzread((gzFile)d->fd, d->c.read.binp->orig_bytes + d->c.read.bin_offset, size); - status = (read_size != -1); + status = (read_size != (size_t) -1); if (!status) { d->errInfo.posix_errno = EIO; } @@ -1213,7 +1213,7 @@ static void invoke_read_line(void *data) d->c.read_line.binp->orig_bytes + d->c.read_line.read_offset + d->c.read_line.read_size, size); - status = (read_size != -1); + status = (read_size != (size_t) -1); if (!status) { d->errInfo.posix_errno = EIO; } @@ -1707,8 +1707,9 @@ static void invoke_pwritev(void *data) { ASSERT(written == size); d->again = 0; } - } else + } else { ASSERT(written >= FILE_SEGMENT_WRITE); + } MUTEX_LOCK(d->c.writev.q_mtx); driver_deq(d->c.pwritev.port, written); @@ -3205,7 +3206,7 @@ static void file_outputv(ErlDrvData e, ErlIOVec *ev) { file_descriptor* desc = (file_descriptor*)e; char command; - int p, q; + size_t p, q; int err; struct t_data *d = NULL; #ifdef USE_VM_PROBES diff --git a/erts/emulator/drivers/common/inet_drv.c b/erts/emulator/drivers/common/inet_drv.c index 301ce2d0e2..60db50e80a 100644 --- a/erts/emulator/drivers/common/inet_drv.c +++ b/erts/emulator/drivers/common/inet_drv.c @@ -282,7 +282,7 @@ static BOOL (WINAPI *fpSetHandleInformation)(HANDLE,DWORD,DWORD); static unsigned long zero_value = 0; static unsigned long one_value = 1; -#else +#else /* #ifdef __WIN32__ */ #include <sys/time.h> #ifdef NETDB_H_NEEDS_IN_H @@ -315,9 +315,17 @@ static unsigned long one_value = 1; #include <net/if.h> +#ifdef HAVE_SCHED_H +#include <sched.h> +#endif + +#ifdef HAVE_SETNS_H +#include <setns.h> +#endif + /* SCTP support -- currently for UNIX platforms only: */ #undef HAVE_SCTP -#if (!defined(__WIN32__) && defined(HAVE_SCTP_H)) +#if defined(HAVE_SCTP_H) #include <netinet/sctp.h> @@ -418,7 +426,7 @@ static int (*p_sctp_bindx)(int sd, struct sockaddr *addrs, static int (*p_sctp_peeloff)(int sd, sctp_assoc_t assoc_id) = NULL; #endif -#endif /* SCTP supported */ +#endif /* #if defined(HAVE_SCTP_H) */ #ifndef WANT_NONBLOCKING #define WANT_NONBLOCKING @@ -512,7 +520,7 @@ static int my_strncasecmp(const char *s1, const char *s2, size_t n) } while(0) -#endif /* __WIN32__ */ +#endif /* #ifdef __WIN32__ #else */ #ifdef HAVE_SOCKLEN_T # define SOCKLEN_T socklen_t @@ -680,6 +688,7 @@ static int my_strncasecmp(const char *s1, const char *s2, size_t n) #define INET_LOPT_TCP_SEND_TIMEOUT_CLOSE 35 /* auto-close on send timeout or not */ #define INET_LOPT_MSGQ_HIWTRMRK 36 /* set local msgq high watermark */ #define INET_LOPT_MSGQ_LOWTRMRK 37 /* set local msgq low watermark */ +#define INET_LOPT_NETNS 38 /* Network namespace pathname */ /* SCTP options: a separate range, from 100: */ #define SCTP_OPT_RTOINFO 100 #define SCTP_OPT_ASSOCINFO 101 @@ -955,6 +964,10 @@ typedef struct { int is_ignored; /* if a fd is ignored by the inet_drv. This flag should be set to true when the fd is used outside of inet_drv. */ +#ifdef HAVE_SETNS + char *netns; /* Socket network namespace name + as full file path */ +#endif } inet_descriptor; @@ -1181,6 +1194,7 @@ static ErlDrvTermData am_dontroute; static ErlDrvTermData am_priority; static ErlDrvTermData am_tos; static ErlDrvTermData am_ipv6_v6only; +static ErlDrvTermData am_netns; #endif /* speical errors for bad ports and sequences */ @@ -3498,6 +3512,7 @@ static void inet_init_sctp(void) { INIT_ATOM(priority); INIT_ATOM(tos); INIT_ATOM(ipv6_v6only); + INIT_ATOM(netns); /* Option names */ INIT_ATOM(sctp_rtoinfo); @@ -3908,12 +3923,81 @@ static int erl_inet_close(inet_descriptor* desc) static ErlDrvSSizeT inet_ctl_open(inet_descriptor* desc, int domain, int type, char** rbuf, ErlDrvSizeT rsize) { + int save_errno; +#ifdef HAVE_SETNS + int current_ns, new_ns; + current_ns = new_ns = 0; +#endif + save_errno = 0; + if (desc->state != INET_STATE_CLOSED) return ctl_xerror(EXBADSEQ, rbuf, rsize); + +#ifdef HAVE_SETNS + if (desc->netns != NULL) { + /* Temporarily change network namespace for this thread + * while creating the socket + */ + current_ns = open("/proc/self/ns/net", O_RDONLY); + if (current_ns == INVALID_SOCKET) + return ctl_error(sock_errno(), rbuf, rsize); + new_ns = open(desc->netns, O_RDONLY); + if (new_ns == INVALID_SOCKET) { + save_errno = sock_errno(); + while (close(current_ns) == INVALID_SOCKET && + sock_errno() == EINTR); + return ctl_error(save_errno, rbuf, rsize); + } + if (setns(new_ns, CLONE_NEWNET) != 0) { + save_errno = sock_errno(); + while (close(new_ns) == INVALID_SOCKET && + sock_errno() == EINTR); + while (close(current_ns) == INVALID_SOCKET && + sock_errno() == EINTR); + return ctl_error(save_errno, rbuf, rsize); + } + else { + while (close(new_ns) == INVALID_SOCKET && + sock_errno() == EINTR); + } + } +#endif if ((desc->s = sock_open(domain, type, desc->sprotocol)) == INVALID_SOCKET) - return ctl_error(sock_errno(), rbuf, rsize); - if ((desc->event = sock_create_event(desc)) == INVALID_EVENT) - return ctl_error(sock_errno(), rbuf, rsize); + save_errno = sock_errno(); +#ifdef HAVE_SETNS + if (desc->netns != NULL) { + /* Restore network namespace */ + if (setns(current_ns, CLONE_NEWNET) != 0) { + /* XXX Failed to restore network namespace. + * What to do? Tidy up and return an error... + * Note that the thread now might still be in the namespace. + * Can this even happen? Should the emulator be aborted? + */ + if (desc->s != INVALID_SOCKET) + save_errno = sock_errno(); + while (close(desc->s) == INVALID_SOCKET && + sock_errno() == EINTR); + desc->s = INVALID_SOCKET; + while (close(current_ns) == INVALID_SOCKET && + sock_errno() == EINTR); + return ctl_error(save_errno, rbuf, rsize); + } + else { + while (close(current_ns) == INVALID_SOCKET && + sock_errno() == EINTR); + } + } +#endif + if (desc->s == INVALID_SOCKET) + return ctl_error(save_errno, rbuf, rsize); + + if ((desc->event = sock_create_event(desc)) == INVALID_EVENT) { + save_errno = sock_errno(); + while (close(desc->s) == INVALID_SOCKET && + sock_errno() == EINTR); + desc->s = INVALID_SOCKET; + return ctl_error(save_errno, rbuf, rsize); + } SET_NONBLOCKING(desc->s); #ifdef __WIN32__ driver_select(desc->port, desc->event, ERL_DRV_READ, 1); @@ -5529,6 +5613,20 @@ static int inet_set_opts(inet_descriptor* desc, char* ptr, int len) } continue; +#ifdef HAVE_SETNS + case INET_LOPT_NETNS: + /* It is annoying that ival and len are both (signed) int */ + if (ival < 0) return -1; + if (len < ival) return -1; + if (desc->netns != NULL) FREE(desc->netns); + desc->netns = ALLOC(((unsigned int) ival) + 1); + memcpy(desc->netns, ptr, ival); + desc->netns[ival] = '\0'; + ptr += ival; + len -= ival; + continue; +#endif + case INET_OPT_REUSEADDR: #ifdef __WIN32__ continue; /* Bjorn says */ @@ -5858,6 +5956,21 @@ static int sctp_set_opts(inet_descriptor* desc, char* ptr, int len) res = 0; continue; +#ifdef HAVE_SETNS + case INET_LOPT_NETNS: + { + size_t ns_len; + ns_len = get_int32(curr); curr += 4; + CHKLEN(curr, ns_len); + if (desc->netns != NULL) FREE(desc->netns); + desc->netns = ALLOC(ns_len + 1); + memcpy(desc->netns, curr, ns_len); + desc->netns[ns_len] = '\0'; + curr += ns_len; + } + continue; +#endif + /* SCTP options and applicable generic INET options: */ case SCTP_OPT_RTOINFO: @@ -6454,6 +6567,22 @@ static ErlDrvSSizeT inet_fill_opts(inet_descriptor* desc, } continue; +#ifdef HAVE_SETNS + case INET_LOPT_NETNS: + if (desc->netns != NULL) { + size_t netns_len; + netns_len = strlen(desc->netns); + *ptr++ = opt; + put_int32(netns_len, ptr); + PLACE_FOR(netns_len, ptr); + memcpy(ptr, desc->netns, netns_len); + ptr += netns_len; + } else { + TRUNCATE_TO(0,ptr); + } + continue; +#endif + case INET_OPT_PRIORITY: #ifdef SO_PRIORITY type = SO_PRIORITY; @@ -6737,6 +6866,22 @@ static ErlDrvSSizeT sctp_fill_opts(inet_descriptor* desc, break; } +#ifdef HAVE_SETNS + case INET_LOPT_NETNS: + if (desc->netns != NULL) { + PLACE_FOR + (spec, i, + LOAD_ATOM_CNT + LOAD_BUF2BINARY_CNT + LOAD_TUPLE_CNT); + i = LOAD_ATOM (spec, i, am_netns); + i = LOAD_BUF2BINARY + (spec, i, desc->netns, strlen(desc->netns)); + i = LOAD_TUPLE (spec, i, 2); + break; + } + else + continue; /* Ignore */ +#endif + /* SCTP and generic INET options: */ case SCTP_OPT_RTOINFO: @@ -7458,6 +7603,10 @@ static ErlDrvSSizeT inet_subscribe(inet_descriptor* desc, static void inet_stop(inet_descriptor* desc) { erl_inet_close(desc); +#ifdef HAVE_SETNS + if (desc->netns != NULL) + FREE(desc->netns); +#endif FREE(desc); } @@ -7537,6 +7686,10 @@ static ErlDrvData inet_start(ErlDrvPort port, int size, int protocol) desc->is_ignored = 0; +#ifdef HAVE_SETNS + desc->netns = NULL; +#endif + return (ErlDrvData)desc; } diff --git a/erts/emulator/sys/common/erl_poll.c b/erts/emulator/sys/common/erl_poll.c index 5861b30315..7676d8872a 100644 --- a/erts/emulator/sys/common/erl_poll.c +++ b/erts/emulator/sys/common/erl_poll.c @@ -123,8 +123,8 @@ static ERTS_INLINE int ERTS_SELECT(int nfds, ERTS_fd_set *readfds, ERTS_fd_set *writefds, ERTS_fd_set *exceptfds, struct timeval *timeout) { - ASSERT(!readfds || readfds->sz >= nfds); - ASSERT(!writefds || writefds->sz >= nfds); + ASSERT(!readfds || readfds->sz >= ERTS_FD_SIZE(nfds)); + ASSERT(!writefds || writefds->sz >= ERTS_FD_SIZE(nfds)); ASSERT(!exceptfds); return select(nfds, (readfds ? readfds->ptr : NULL ), diff --git a/erts/etc/unix/cerl.src b/erts/etc/unix/cerl.src index 0d45917e4b..41baa323ed 100644 --- a/erts/etc/unix/cerl.src +++ b/erts/etc/unix/cerl.src @@ -283,6 +283,19 @@ if [ "x$GDB" = "x" ]; then else valgrind_misc_flags="$VALGRIND_MISC_FLAGS" fi + if which taskset > /dev/null && test -e /proc/cpuinfo; then + # We only let valgrind utilize one core with "taskset 1" as it can be very slow + # on multiple cores (especially with async threads). Valgrind only run one pthread + # at a time anyway so there is no point letting it utilize more than one core. + # Use $sched_arg to force all schedulers online to emulate multicore. + taskset1="taskset 1" + ncpu=`cat /proc/cpuinfo | grep -w processor | wc -l` + sched_arg="-S$ncpu:$ncpu" + else + taskset1= + sched_arg= + fi + beam_args=`$EXEC -emu_args_exit ${1+"$@"}` # Time for some argument passing voodoo: @@ -293,7 +306,7 @@ if [ "x$GDB" = "x" ]; then ' set -- $beam_args IFS="$SAVE_IFS" - exec valgrind $valgrind_xml $valgrind_log $valgrind_misc_flags $BINDIR/$EMU_NAME $emu_xargs "$@" -pz $PRELOADED + exec $taskset1 valgrind $valgrind_xml $valgrind_log $valgrind_misc_flags $BINDIR/$EMU_NAME $sched_arg $emu_xargs "$@" -pz $PRELOADED else exec $EXEC $eeargs $xargs ${1+"$@"} fi diff --git a/erts/preloaded/ebin/prim_inet.beam b/erts/preloaded/ebin/prim_inet.beam Binary files differindex 8638ef677e..5b38871282 100644 --- a/erts/preloaded/ebin/prim_inet.beam +++ b/erts/preloaded/ebin/prim_inet.beam diff --git a/erts/preloaded/src/prim_inet.erl b/erts/preloaded/src/prim_inet.erl index fb1269cf91..fa621681f3 100644 --- a/erts/preloaded/src/prim_inet.erl +++ b/erts/preloaded/src/prim_inet.erl @@ -25,7 +25,7 @@ %% Primitive inet_drv interface --export([open/3, fdopen/4, close/1]). +-export([open/3, open/4, fdopen/4, close/1]). -export([bind/3, listen/1, listen/2, peeloff/2]). -export([connect/3, connect/4, async_connect/4]). -export([accept/1, accept/2, async_accept/2]). @@ -64,22 +64,31 @@ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% open(Protocol, Family, Type) -> - open(Protocol, Family, Type, ?INET_REQ_OPEN, []). + open(Protocol, Family, Type, [], ?INET_REQ_OPEN, []). + +open(Protocol, Family, Type, Opts) -> + open(Protocol, Family, Type, Opts, ?INET_REQ_OPEN, []). fdopen(Protocol, Family, Type, Fd) when is_integer(Fd) -> - open(Protocol, Family, Type, ?INET_REQ_FDOPEN, ?int32(Fd)). + open(Protocol, Family, Type, [], ?INET_REQ_FDOPEN, ?int32(Fd)). -open(Protocol, Family, Type, Req, Data) -> +open(Protocol, Family, Type, Opts, Req, Data) -> Drv = protocol2drv(Protocol), AF = enc_family(Family), T = enc_type(Type), try erlang:open_port({spawn_driver,Drv}, [binary]) of S -> - case ctl_cmd(S, Req, [AF,T,Data]) of - {ok,_} -> {ok,S}; - {error,_}=Error -> + case setopts(S, Opts) of + ok -> + case ctl_cmd(S, Req, [AF,T,Data]) of + {ok,_} -> {ok,S}; + {error,_}=E1 -> + close(S), + E1 + end; + {error,_}=E2 -> close(S), - Error + E2 end catch %% The only (?) way to get here is to try to open @@ -1108,6 +1117,7 @@ enc_opt(send_timeout_close) -> ?INET_LOPT_TCP_SEND_TIMEOUT_CLOSE; enc_opt(delay_send) -> ?INET_LOPT_TCP_DELAY_SEND; enc_opt(packet_size) -> ?INET_LOPT_PACKET_SIZE; enc_opt(read_packets) -> ?INET_LOPT_READ_PACKETS; +enc_opt(netns) -> ?INET_LOPT_NETNS; enc_opt(raw) -> ?INET_OPT_RAW; % Names of SCTP opts: enc_opt(sctp_rtoinfo) -> ?SCTP_OPT_RTOINFO; @@ -1164,6 +1174,7 @@ dec_opt(?INET_LOPT_TCP_SEND_TIMEOUT_CLOSE) -> send_timeout_close; dec_opt(?INET_LOPT_TCP_DELAY_SEND) -> delay_send; dec_opt(?INET_LOPT_PACKET_SIZE) -> packet_size; dec_opt(?INET_LOPT_READ_PACKETS) -> read_packets; +dec_opt(?INET_LOPT_NETNS) -> netns; dec_opt(?INET_OPT_RAW) -> raw; dec_opt(I) when is_integer(I) -> undefined. @@ -1261,6 +1272,7 @@ type_opt_1(send_timeout_close) -> bool; type_opt_1(delay_send) -> bool; type_opt_1(packet_size) -> uint; type_opt_1(read_packets) -> uint; +type_opt_1(netns) -> binary; %% %% SCTP options (to be set). If the type is a record type, the corresponding %% record signature is returned, otherwise, an "elementary" type tag @@ -1487,9 +1499,12 @@ type_value_2({bitenumlist,List,_}, EnumList) -> Ls when is_list(Ls) -> true; false -> false end; -type_value_2(binary,Bin) when is_binary(Bin) -> true; -type_value_2(binary_or_uint,Bin) when is_binary(Bin) -> true; -type_value_2(binary_or_uint,Int) when is_integer(Int), Int >= 0 -> true; +type_value_2(binary,Bin) + when is_binary(Bin), byte_size(Bin) < (1 bsl 32) -> true; +type_value_2(binary_or_uint,Bin) + when is_binary(Bin), byte_size(Bin) < (1 bsl 32) -> true; +type_value_2(binary_or_uint,Int) + when is_integer(Int), Int >= 0 -> true; %% Type-checking of SCTP options type_value_2(sctp_assoc_id, X) when X band 16#ffffffff =:= X -> true; diff --git a/lib/Makefile b/lib/Makefile index 9ddf3a0544..47a6d5f9aa 100644 --- a/lib/Makefile +++ b/lib/Makefile @@ -19,20 +19,32 @@ include $(ERL_TOP)/make/target.mk include $(ERL_TOP)/make/$(TARGET)/otp.mk -ERTS_SUB_DIRECTORIES = stdlib sasl kernel compiler -OTHER_SUB_DIRECTORIES = tools test_server common_test runtime_tools \ + +# These have to be built first +ERTS_APPLICATIONS = stdlib sasl kernel compiler + +# Then these have to be build +ERLANG_APPLICATIONS = tools test_server common_test runtime_tools \ inets xmerl edoc erl_docgen + +# These are only build if -a is given to otp_build or make is used directly +ALL_ERLANG_APPLICATIONS = snmp otp_mibs appmon erl_interface asn1 jinterface \ + wx debugger reltool gs \ + ic mnesia crypto orber os_mon parsetools syntax_tools \ + pman public_key ssl toolbar tv observer odbc diameter \ + cosTransactions cosEvent cosTime cosNotification \ + cosProperty cosFileTransfer cosEventDomain et megaco webtool \ + eunit ssh typer percept eldap dialyzer hipe + ifdef BUILD_ALL - OTHER_SUB_DIRECTORIES += \ - snmp otp_mibs appmon erl_interface asn1 jinterface \ - wx debugger reltool gs \ - ic mnesia crypto orber os_mon parsetools syntax_tools \ - pman public_key ssl toolbar tv observer odbc diameter \ - cosTransactions cosEvent cosTime cosNotification \ - cosProperty cosFileTransfer cosEventDomain et megaco webtool \ - eunit ssh typer percept eldap dialyzer hipe - EXTRA_FILE := $(wildcard EXTRA-APPLICATIONS) - EXTRA_APPLICATIONS := $(if $(EXTRA_FILE),$(shell cat $(EXTRA_FILE))) + ERLANG_APPLICATIONS += $(ALL_ERLANG_APPLICATIONS) + +# We use whildcard */ to figure out if there are any other applications +# in here. + EXPECTED_APPLICATIONS := $(ERTS_APPLICATIONS) $(ERLANG_APPLICATIONS) \ + autom4te.cache + EXTRA_APPLICATIONS += $(filter-out $(EXPECTED_APPLICATIONS),\ + $(subst /,,$(wildcard */))) endif ifdef BOOTSTRAP @@ -45,13 +57,17 @@ else ifdef TERTIARY_BOOTSTRAP SUB_DIRECTORIES = snmp sasl jinterface ic syntax_tools wx else # Not bootstrap build - SUB_DIRECTORIES = $(ERTS_SUB_DIRECTORIES) \ - $(OTHER_SUB_DIRECTORIES) \ + SUB_DIRECTORIES = $(ERTS_APPLICATIONS) \ + $(ERLANG_APPLICATIONS) \ $(EXTRA_APPLICATIONS) endif endif endif +# Any applications listed in SKIP-APPLICATIONS should be skipped +SKIP_FILE := $(wildcard SKIP-APPLICATIONS) +SKIP_APPLICATIONS := $(if $(SKIP_FILE),$(shell cat $(SKIP_FILE))) +SUB_DIRECTORIES := $(filter-out $(SKIP_APPLICATIONS),$(SUB_DIRECTORIES)) # ---------------------------------------------------------------------- include $(ERL_TOP)/make/otp_subdir.mk diff --git a/lib/asn1/src/Makefile b/lib/asn1/src/Makefile index 33cd3cc4c3..3f24e15c04 100644 --- a/lib/asn1/src/Makefile +++ b/lib/asn1/src/Makefile @@ -43,9 +43,7 @@ RELSYSDIR = $(RELEASE_PATH)/lib/asn1-$(VSN) EBIN = ../ebin -EVAL_CT_MODULES = asn1ct_eval_ext \ - asn1ct_eval_per \ - asn1ct_eval_uper +EVAL_CT_MODULES = asn1ct_eval_ext CT_MODULES= \ asn1ct \ @@ -55,7 +53,6 @@ CT_MODULES= \ asn1ct_func \ asn1ct_gen \ asn1ct_gen_per \ - asn1ct_gen_per_rt2ct \ asn1ct_name \ asn1ct_constructed_per \ asn1ct_constructed_ber_bin_v2 \ diff --git a/lib/asn1/src/asn1_db.erl b/lib/asn1/src/asn1_db.erl index 869b36ddbd..48d9dd16d7 100644 --- a/lib/asn1/src/asn1_db.erl +++ b/lib/asn1/src/asn1_db.erl @@ -19,25 +19,37 @@ %% -module(asn1_db). --export([dbstart/1,dbnew/1,dbsave/2,dbput/3,dbget/2]). +-export([dbstart/1,dbnew/2,dbload/1,dbload/3,dbsave/2,dbput/3,dbget/2]). -export([dbstop/0]). -record(state, {parent, monitor, includes, table}). %% Interface -dbstart(Includes) -> +dbstart(Includes0) -> + Includes = case Includes0 of + [] -> ["."]; + [_|_] -> Includes0 + end, Parent = self(), undefined = get(?MODULE), %Assertion. put(?MODULE, spawn_link(fun() -> init(Parent, Includes) end)), ok. -dbnew(Module) -> req({new, Module}). +dbload(Module, Erule, Mtime) -> + req({load, Module, Erule, Mtime}). + +dbload(Module) -> + req({load, Module, any, {{0,0,0},{0,0,0}}}). + +dbnew(Module, Erule) -> req({new, Module, Erule}). dbsave(OutFile, Module) -> cast({save, OutFile, Module}). dbput(Module, K, V) -> cast({set, Module, K, V}). dbget(Module, K) -> req({get, Module, K}). dbstop() -> Resp = req(stop), erase(?MODULE), Resp. %% Internal functions +-define(MAGIC_KEY, '__version_and_erule__'). + req(Request) -> DbPid = get(?MODULE), Ref = erlang:monitor(process,DbPid), @@ -71,47 +83,57 @@ loop(#state{parent = Parent, monitor = MRef, table = Table, ets:insert(Modtab, {K2, V}), loop(State); {From, {get, Mod, K2}} -> - Result = case ets:lookup(Table, Mod) of - [] -> opentab(Table, Mod, Includes); - [{_, Modtab}] -> {ok, Modtab} - end, - case Result of - {ok, Newtab} -> reply(From, lookup(Newtab, K2)); - _Error -> reply(From, undefined) + %% XXX If there is no information for Mod, get_table/3 + %% will attempt to load information from an .asn1db + %% file, without comparing its timestamp against the + %% source file. This is known to happen when check_* + %% functions for DER are generated, but it could possibly + %% happen in other circumstances. Ideally, this issue should + %% be rectified in some way, perhaps by ensuring that + %% the module has been loaded (using dbload/4) prior + %% to calling dbget/2. + case get_table(Table, Mod, Includes) of + {ok,Tab} -> reply(From, lookup(Tab, K2)); + error -> reply(From, undefined) end, loop(State); {save, OutFile, Mod} -> [{_,Mtab}] = ets:lookup(Table, Mod), ok = ets:tab2file(Mtab, OutFile), loop(State); - {From, {new, Mod}} -> + {From, {new, Mod, Erule}} -> [] = ets:lookup(Table, Mod), %Assertion. ModTableId = ets:new(list_to_atom(lists:concat(["asn1_",Mod])), []), ets:insert(Table, {Mod, ModTableId}), + ets:insert(ModTableId, {?MAGIC_KEY, info(Erule)}), reply(From, ok), loop(State); + {From, {load, Mod, Erule, Mtime}} -> + case ets:member(Table, Mod) of + true -> + reply(From, ok); + false -> + case load_table(Mod, Erule, Mtime, Includes) of + {ok, ModTableId} -> + ets:insert(Table, {Mod, ModTableId}), + reply(From, ok); + error -> + reply(From, error) + end + end, + loop(State); {From, stop} -> reply(From, stopped); %% Nothing to store {'DOWN', MRef, process, Parent, Reason} -> exit(Reason) end. -opentab(Tab, Mod, []) -> - opentab(Tab, Mod, ["."]); -opentab(Tab, Mod, Includes) -> - Base = lists:concat([Mod, ".asn1db"]), - opentab2(Tab, Base, Mod, Includes, ok). - -opentab2(_Tab, _Base, _Mod, [], Error) -> - Error; -opentab2(Tab, Base, Mod, [Ih|It], _Error) -> - File = filename:join(Ih, Base), - case ets:file2tab(File) of - {ok, Modtab} -> - ets:insert(Tab, {Mod, Modtab}), - {ok, Modtab}; - NewErr -> - opentab2(Tab, Base, Mod, It, NewErr) +get_table(Table, Mod, Includes) -> + case ets:lookup(Table, Mod) of + [{Mod,Tab}] -> + {ok,Tab}; + [] -> + load_table(Mod, any, {{0,0,0},{0,0,0}}, Includes) end. lookup(Tab, K) -> @@ -119,3 +141,43 @@ lookup(Tab, K) -> [] -> undefined; [{K,V}] -> V end. + +info(Erule) -> + {asn1ct:vsn(),Erule}. + +load_table(Mod, Erule, Mtime, Includes) -> + Base = lists:concat([Mod, ".asn1db"]), + case path_find(Includes, Mtime, Base) of + error -> + error; + {ok,ModTab} when Erule =:= any -> + {ok,ModTab}; + {ok,ModTab} -> + Vsn = asn1ct:vsn(), + case ets:lookup(ModTab, ?MAGIC_KEY) of + [{_,{Vsn,Erule}}] -> + %% Correct version and encoding rule. + {ok,ModTab}; + _ -> + %% Missing key or wrong version/encoding rule. + ets:delete(ModTab), + error + end + end. + +path_find([H|T], Mtime, Base) -> + File = filename:join(H, Base), + case filelib:last_modified(File) of + 0 -> + path_find(T, Mtime, Base); + DbMtime when DbMtime >= Mtime -> + case ets:file2tab(File) of + {ok,_}=Ret -> + Ret; + _ -> + path_find(T, Mtime, Base) + end; + _ -> + path_find(T, Mtime, Base) + end; +path_find([], _, _) -> error. diff --git a/lib/asn1/src/asn1ct.erl b/lib/asn1/src/asn1ct.erl index 8e71a5697c..f2ccf5f212 100644 --- a/lib/asn1/src/asn1ct.erl +++ b/lib/asn1/src/asn1ct.erl @@ -893,17 +893,23 @@ parse_and_save(Module,S) -> Options = S#state.options, SourceDir = S#state.sourcedir, Includes = [I || {i,I} <- Options], + Erule = S#state.erule, case get_input_file(Module, [SourceDir|Includes]) of %% search for asn1 source {file,SuffixedASN1source} -> - case dbfile_uptodate(SuffixedASN1source,Options) of - false -> - parse_and_save1(S, SuffixedASN1source, Options); - _ -> ok + Mtime = filelib:last_modified(SuffixedASN1source), + case asn1_db:dbload(Module, Erule, Mtime) of + ok -> ok; + error -> parse_and_save1(S, SuffixedASN1source, Options) end; Err -> - warning("could not do a consistency check of the ~p file: no asn1 source file was found.~n", - [lists:concat([Module,".asn1db"])],Options), + case asn1_db:dbload(Module) of + ok -> + warning("could not do a consistency check of the ~p file: no asn1 source file was found.~n", + [lists:concat([Module,".asn1db"])],Options); + error -> + ok + end, {error,{asn1,input_file_error,Err}} end. @@ -929,48 +935,6 @@ get_input_file(Module,[I|Includes]) -> get_input_file(Module,Includes) end. -dbfile_uptodate(File,Options) -> - EncodingRule = get_rule(Options), - Ext = filename:extension(File), - Base = filename:basename(File,Ext), - DbFile = outfile(Base,"asn1db",Options), - case file:read_file_info(DbFile) of - {error,enoent} -> - false; - {ok,FileInfoDb} -> - %% file exists, check date and finally encodingrule - {ok,FileInfoAsn} = file:read_file_info(File), - case FileInfoDb#file_info.mtime < FileInfoAsn#file_info.mtime of - true -> - %% date of asn1 spec newer than db file - false; - _ -> - %% date ok,check that same erule was used - Obase = case lists:keysearch(outdir, 1, Options) of - {value, {outdir, Odir}} -> - Odir; - _NotFound -> "" - end, - BeamFileName = outfile(Base,"beam",Options), - case file:read_file_info(BeamFileName) of - {ok,_} -> - code:add_path(Obase), - BeamFile = list_to_atom(Base), - BeamInfo = (catch BeamFile:info()), - case catch lists:keysearch(options,1,BeamInfo) of - {value,{options,OldOptions}} -> - case get_rule(OldOptions) of - EncodingRule -> true; - _ -> false - end; - _ -> false - end; - _ -> false - end - end - end. - - input_file_type(Name,I) -> case input_file_type(Name) of {error,_} -> input_file_type2(filename:basename(Name),I); @@ -1374,10 +1338,11 @@ get_value(Module, Type) -> end. check(Module, Includes) -> - case asn1_db:dbget(Module,'MODULE') of - undefined -> - {error, {file_not_found, lists:concat([Module, ".asn1db"])}}; - M -> + case asn1_db:dbload(Module) of + error -> + {error,asn1db_missing_or_out_of_date}; + ok -> + M = asn1_db:dbget(Module, 'MODULE'), TypeOrVal = M#module.typeorval, State = #state{mname = M#module.name, module = M#module{typeorval=[]}, diff --git a/lib/asn1/src/asn1ct_check.erl b/lib/asn1/src/asn1ct_check.erl index f94550b0a4..eddcda0018 100644 --- a/lib/asn1/src/asn1ct_check.erl +++ b/lib/asn1/src/asn1ct_check.erl @@ -1557,21 +1557,32 @@ check_objectdefn(S,Def,CDef) when is_record(CDef,classdef) -> exit({error,{objectdefn,Other}}) end. -check_defaultfields(S,Fields,ClassFields) -> - check_defaultfields(S,Fields,ClassFields,[]). +check_defaultfields(S, Fields, ClassFields) -> + Present = ordsets:from_list([F || {F,_} <- Fields]), + Mandatory0 = get_mandatory_class_fields(ClassFields), + Mandatory = ordsets:from_list(Mandatory0), + All = ordsets:from_list([element(2, F) || F <- ClassFields]), + #state{type=T,tname=Obj} = S, + case ordsets:subtract(Present, All) of + [] -> + ok; + [_|_]=Invalid -> + throw(asn1_error(S, T, {invalid_fields,Invalid,Obj})) + end, + case ordsets:subtract(Mandatory, Present) of + [] -> + check_defaultfields_1(S, Fields, ClassFields, []); + [_|_]=Missing -> + throw(asn1_error(S, T, {missing_mandatory_fields,Missing,Obj})) + end. -check_defaultfields(_S,[],_ClassFields,Acc) -> +check_defaultfields_1(_S, [], _ClassFields, Acc) -> {object,defaultsyntax,lists:reverse(Acc)}; -check_defaultfields(S,[{FName,Spec}|Fields],ClassFields,Acc) -> - case lists:keysearch(FName,2,ClassFields) of - {value,CField} -> - {NewField,RestFields} = - convert_to_defaultfield(S,FName,[Spec|Fields],CField), - check_defaultfields(S,RestFields,ClassFields,[NewField|Acc]); - _ -> - throw({error,{asn1,{'unvalid field in object',FName}}}) - end. -%% {object,defaultsyntax,Fields}. +check_defaultfields_1(S, [{FName,Spec}|Fields], ClassFields, Acc) -> + CField = lists:keyfind(FName, 2, ClassFields), + {NewField,RestFields} = + convert_to_defaultfield(S, FName, [Spec|Fields], CField), + check_defaultfields_1(S, RestFields, ClassFields, [NewField|Acc]). convert_definedsyntax(_S,[],[],_ClassFields,Acc) -> lists:reverse(Acc); @@ -1587,6 +1598,23 @@ convert_definedsyntax(S,Fields,WithSyntax,ClassFields,Acc) -> [MatchedField|Acc]) end. +get_mandatory_class_fields([{fixedtypevaluefield,Name,_,_,'MANDATORY'}|T]) -> + [Name|get_mandatory_class_fields(T)]; +get_mandatory_class_fields([{objectfield,Name,_,_,'MANDATORY'}|T]) -> + [Name|get_mandatory_class_fields(T)]; +get_mandatory_class_fields([{objectsetfield,Name,_,'MANDATORY'}|T]) -> + [Name|get_mandatory_class_fields(T)]; +get_mandatory_class_fields([{typefield,Name,'MANDATORY'}|T]) -> + [Name|get_mandatory_class_fields(T)]; +get_mandatory_class_fields([{variabletypevaluefield,Name,_,'MANDATORY'}|T]) -> + [Name|get_mandatory_class_fields(T)]; +get_mandatory_class_fields([{variabletypevaluesetfield, + Name,_,'MANDATORY'}|T]) -> + [Name|get_mandatory_class_fields(T)]; +get_mandatory_class_fields([_|T]) -> + get_mandatory_class_fields(T); +get_mandatory_class_fields([]) -> []. + match_field(S,Fields,WithSyntax,ClassFields) -> match_field(S,Fields,WithSyntax,ClassFields,[]). @@ -6798,7 +6826,7 @@ merge_tags2([], Acc) -> storeindb(S,M) when is_record(M,module) -> TVlist = M#module.typeorval, NewM = M#module{typeorval=findtypes_and_values(TVlist)}, - asn1_db:dbnew(NewM#module.name), + asn1_db:dbnew(NewM#module.name, S#state.erule), asn1_db:dbput(NewM#module.name,'MODULE', NewM), Res = storeindb(#state{mname=NewM#module.name}, TVlist, []), include_default_class(S,NewM#module.name), @@ -6867,11 +6895,22 @@ asn1_error(#state{mname=Where}, Item, Error) -> format_error({already_defined,Name,PrevLine}) -> io_lib:format("the name ~p has already been defined at line ~p", [Name,PrevLine]); +format_error({invalid_fields,Fields,Obj}) -> + io_lib:format("invalid ~s in ~p", [format_fields(Fields),Obj]); +format_error({missing_mandatory_fields,Fields,Obj}) -> + io_lib:format("missing mandatory ~s in ~p", + [format_fields(Fields),Obj]); format_error({undefined,Name}) -> io_lib:format("'~s' is referenced, but is not defined", [Name]); format_error(Other) -> io_lib:format("~p", [Other]). +format_fields([F]) -> + io_lib:format("field &~s", [F]); +format_fields([H|T]) -> + [io_lib:format("fields &~s", [H])| + [io_lib:format(", &~s", [F]) || F <- T]]. + error({_,{structured_error,_,_,_}=SE,_}) -> SE; error({export,Msg,#state{mname=Mname,type=Ref,tname=Typename}}) -> diff --git a/lib/asn1/src/asn1ct_constructed_ber_bin_v2.erl b/lib/asn1/src/asn1ct_constructed_ber_bin_v2.erl index 761faa53c5..8359b81b33 100644 --- a/lib/asn1/src/asn1ct_constructed_ber_bin_v2.erl +++ b/lib/asn1/src/asn1ct_constructed_ber_bin_v2.erl @@ -122,8 +122,8 @@ gen_encode_sequence(Erules,Typename,D) when is_record(D,type) -> asn1ct_gen:un_hyphen_var(lists:concat(['Obj', AttrN])), emit([ObjectEncode," = ",nl, - " ",{asis,ObjSetMod},":'getenc_",ObjSetName, - "'(",{asis,UniqueFieldName},", ",nl]), + " ",{asis,ObjSetMod},":'getenc_",ObjSetName, + "'("]), ValueMatch = value_match(ValueIndex, lists:concat(["Cindex",N])), emit([indent(35),ValueMatch,"),",nl]), @@ -198,7 +198,7 @@ gen_decode_sequence(Erules,Typename,D) when is_record(D,type) -> asn1ct_name:new(tlv), asn1ct_name:new(v), - {DecObjInf,UniqueFName,ValueIndex} = + {DecObjInf,ValueIndex} = case TableConsInfo of #simpletableattributes{objectsetname=ObjectSetRef, c_name=AttrN, @@ -217,12 +217,12 @@ gen_decode_sequence(Erules,Typename,D) when is_record(D,type) -> %% relation from a component to another components %% subtype component {{AttrN,{deep,ObjectSetRef,UniqueFieldName,ValIndex}}, - UniqueFieldName,ValIndex}; + ValIndex}; false -> - {{AttrN,ObjectSetRef},UniqueFieldName,ValIndex} + {{AttrN,ObjectSetRef},ValIndex} end; _ -> - {false,false,false} + {false,false} end, RecordName = lists:concat([get_record_name_prefix(), asn1ct_gen:list2rname(Typename)]), @@ -246,7 +246,7 @@ gen_decode_sequence(Erules,Typename,D) when is_record(D,type) -> {ObjSetMod,ObjSetName} = ObjSetRef, emit([DecObj," =",nl, " ",{asis,ObjSetMod},":'getdec_",ObjSetName,"'(", - {asis,UniqueFName},", ",ValueMatch,"),",nl]), + ValueMatch,"),",nl]), gen_dec_postponed_decs(DecObj,PostponedDecArgs) end, demit(["Result = "]), %dbg @@ -357,7 +357,7 @@ gen_decode_set(Erules,Typename,D) when is_record(D,type) -> asn1ct_name:new(v), - {DecObjInf,UniqueFName,ValueIndex} = + {DecObjInf,ValueIndex} = case TableConsInfo of %% {ObjectSetRef,AttrN,_N,UniqueFieldName} ->%% N is index of attribute that determines constraint #simpletableattributes{objectsetname=ObjectSetRef, @@ -378,12 +378,12 @@ gen_decode_set(Erules,Typename,D) when is_record(D,type) -> %% relation from a component to another components %% subtype component {{AttrN,{deep,ObjectSetRef,UniqueFieldName,ValIndex}}, - UniqueFieldName,ValIndex}; + ValIndex}; false -> - {{AttrN,ObjectSetRef},UniqueFieldName,ValIndex} + {{AttrN,ObjectSetRef},ValIndex} end; _ -> - {false,false,false} + {false,false} end, case CompList of @@ -425,7 +425,7 @@ gen_decode_set(Erules,Typename,D) when is_record(D,type) -> {ObjSetMod,ObjSetName} = ObjSetRef, emit([DecObj," =",nl, " ",{asis,ObjSetMod},":'getdec_",ObjSetName,"'(", - {asis,UniqueFName},", ",ValueMatch,"),",nl]), + ValueMatch,"),",nl]), gen_dec_postponed_decs(DecObj,PostponedDecArgs) end, demit(["Result = "]), %dbg @@ -577,6 +577,8 @@ gen_decode_choice(Erules,Typename,D) when is_record(D,type) -> gen_enc_sequence_call(Erules,TopType,[#'ComponentType'{name=Cname,typespec=Type,prop=Prop,textual_order=Order}|Rest],Pos,Ext,EncObj) -> asn1ct_name:new(encBytes), asn1ct_name:new(encLen), + asn1ct_name:new(tmpBytes), + asn1ct_name:new(tmpLen), CindexPos = case Order of undefined -> @@ -706,8 +708,6 @@ emit_term_tlv('OPTIONAL',InnerType,DecObjInf) -> emit_term_tlv(opt_or_def,InnerType,DecObjInf); emit_term_tlv(Prop,{typefield,_},DecObjInf) -> emit_term_tlv(Prop,type_or_object_field,DecObjInf); -emit_term_tlv(Prop,{objectfield,_,_},DecObjInf) -> - emit_term_tlv(Prop,type_or_object_field,DecObjInf); emit_term_tlv(opt_or_def,type_or_object_field,NotFalse) when NotFalse /= false -> asn1ct_name:new(tmpterm), @@ -789,6 +789,7 @@ gen_enc_choice2(Erules,TopType,[H1|T]) when is_record(H1,'ComponentType') -> componentrelation)} of {#'ObjectClassFieldType'{},{componentrelation,_,_}} -> asn1ct_name:new(tmpBytes), + asn1ct_name:new(tmpLen), asn1ct_name:new(encBytes), asn1ct_name:new(encLen), Emit = ["{",{curr,tmpBytes},", _} = "], @@ -929,7 +930,6 @@ gen_enc_line(Erules,TopType,Cname, when is_list(Element) -> case asn1ct_gen:get_constraint(C,componentrelation) of {componentrelation,_,_} -> - asn1ct_name:new(tmpBytes), gen_enc_line(Erules,TopType,Cname,Type,Element,Indent,OptOrMand, ["{",{curr,tmpBytes},",_} = "],EncObj); _ -> @@ -991,12 +991,8 @@ gen_enc_line(Erules,TopType,Cname,Type,Element,Indent,OptOrMand,Assign,EncObj) {call,ber,encode_open_type, [{curr,tmpBytes},{asis,Tag}]},nl]); _ -> - emit(["{",{next,tmpBytes},",",{curr,tmpLen}, - "} = ", - {call,ber,encode_open_type, - [{curr,tmpBytes},{asis,Tag}]},com,nl]), - emit(IndDeep), - emit(["{",{next,tmpBytes},", ",{curr,tmpLen},"}"]) + emit([{call,ber,encode_open_type, + [{curr,tmpBytes},{asis,Tag}]}]) end; Err -> throw({asn1,{'internal error',Err}}) @@ -1213,22 +1209,18 @@ gen_dec_call({typefield,_},_,_,Cname,Type,BytesVar,Tag,_,_,_DecObjInf,OptOrMandC (Type#type.def)#'ObjectClassFieldType'.fieldname, [{Cname,RefedFieldName,asn1ct_gen:mk_var(asn1ct_name:curr(term)), asn1ct_gen:mk_var(asn1ct_name:curr(tmpterm)),Tag,OptOrMandComp}]; -gen_dec_call({objectfield,PrimFieldName,PFNList},_,_,Cname,_,BytesVar,Tag,_,_,_,OptOrMandComp) -> - call(decode_open_type, [BytesVar,{asis,Tag}]), - [{Cname,{PrimFieldName,PFNList},asn1ct_gen:mk_var(asn1ct_name:curr(term)), - asn1ct_gen:mk_var(asn1ct_name:curr(tmpterm)),Tag,OptOrMandComp}]; gen_dec_call(InnerType,Erules,TopType,Cname,Type,BytesVar,Tag,PrimOptOrMand, OptOrMand,DecObjInf,_) -> WhatKind = asn1ct_gen:type(InnerType), gen_dec_call1(WhatKind,InnerType,Erules,TopType,Cname,Type,BytesVar,Tag, PrimOptOrMand,OptOrMand), case DecObjInf of - {Cname,{_,OSet,UniqueFName,ValIndex}} -> + {Cname,{_,OSet,_UniqueFName,ValIndex}} -> Term = asn1ct_gen:mk_var(asn1ct_name:curr(term)), ValueMatch = value_match(ValIndex,Term), {ObjSetMod,ObjSetName} = OSet, emit([",",nl,"ObjFun = ",{asis,ObjSetMod},":'getdec_",ObjSetName, - "'(",{asis,UniqueFName},", ",ValueMatch,")"]); + "'(",ValueMatch,")"]); _ -> ok end, diff --git a/lib/asn1/src/asn1ct_constructed_per.erl b/lib/asn1/src/asn1ct_constructed_per.erl index d279e9697f..8d4afc0a0b 100644 --- a/lib/asn1/src/asn1ct_constructed_per.erl +++ b/lib/asn1/src/asn1ct_constructed_per.erl @@ -43,10 +43,13 @@ gen_encode_set(Erules,TypeName,D) -> gen_encode_sequence(Erules,TypeName,D) -> gen_encode_constructed(Erules,TypeName,D). -gen_encode_constructed(Erule,Typename,D) when is_record(D,type) -> +gen_encode_constructed(Erule, Typename, #type{}=D) -> asn1ct_name:start(), - asn1ct_name:new(term), - asn1ct_name:new(bytes), + Imm = gen_encode_constructed_imm(Erule, Typename, D), + asn1ct_imm:enc_cg(Imm, is_aligned(Erule)), + emit([".",nl]). + +gen_encode_constructed_imm(Erule, Typename, #type{}=D) -> {ExtAddGroup,TmpCompList,TableConsInfo} = case D#type.def of #'SEQUENCE'{tablecinf=TCI,components=CL,extaddgroup=ExtAddGroup0} -> @@ -65,74 +68,36 @@ gen_encode_constructed(Erule,Typename,D) when is_record(D,type) -> [Comp#'ComponentType'{textual_order=undefined}|| Comp<-TmpCompList] end, - case Typename of - ['EXTERNAL'] -> - emit([{next,val}," = ", - {call,ext,transform_to_EXTERNAL1990, - [{curr,val}]},com,nl]), - asn1ct_name:new(val); - _ -> - ok - end, - case {Optionals = optionals(to_textual_order(CompList)),CompList, - is_optimized(Erule)} of - {[],EmptyCL,_} when EmptyCL == {[],[],[]};EmptyCL == {[],[]};EmptyCL == [] -> - ok; - {[],_,_} -> - emit([{next,val}," = ",{curr,val},",",nl]); - {_,_,true} -> - gen_fixoptionals(Optionals), - FixOpts = param_map(fun(Var) -> - {var,Var} - end,asn1ct_name:all(fixopt)), - emit({"{",{next,val},",Opt} = {",{curr,val},",[",FixOpts,"]},",nl}); - {_,_,false} -> - asn1ct_func:need({Erule,fixoptionals,3}), - Fixoptcall = ",Opt} = fixoptionals(", - emit({"{",{next,val},Fixoptcall, - {asis,Optionals},",",length(Optionals), - ",",{curr,val},"),",nl}) - end, - asn1ct_name:new(val), + ExternalImm = + case Typename of + ['EXTERNAL'] -> + Next = asn1ct_gen:mk_var(asn1ct_name:next(val)), + Curr = asn1ct_gen:mk_var(asn1ct_name:curr(val)), + asn1ct_name:new(val), + [{call,ext,transform_to_EXTERNAL1990,[{var,Curr}],{var,Next}}]; + _ -> + [] + end, + Aligned = is_aligned(Erule), + Value0 = asn1ct_gen:mk_var(asn1ct_name:curr(val)), + Optionals = optionals(to_textual_order(CompList)), + ImmOptionals = [asn1ct_imm:per_enc_optional(Value0, Opt, Aligned) || + Opt <- Optionals], Ext = extensible_enc(CompList), - case Ext of - {ext,_,NumExt} when NumExt > 0 -> - case extgroup_pos_and_length(CompList) of - {extgrouppos,[]} -> % no extenstionAdditionGroup - ok; - {extgrouppos,ExtGroupPosLenList} -> - ExtGroupFun = - fun({ExtActualGroupPos,ExtGroupVirtualPos,ExtGroupLen}) -> - Elements = - make_elements(ExtGroupVirtualPos+1, - "Val1", - lists:seq(1,ExtGroupLen)), - emit([ - {next,val}," = case [X || X <- [",Elements, - "],X =/= asn1_NOVALUE] of",nl, - "[] -> setelement(", - {asis,ExtActualGroupPos+1},",", - {curr,val},",", - "asn1_NOVALUE);",nl, - "_ -> setelement(",{asis,ExtActualGroupPos+1},",", - {curr,val},",", - "{extaddgroup,", Elements,"})",nl, - "end,",nl]), - asn1ct_name:new(val) - end, - lists:foreach(ExtGroupFun,ExtGroupPosLenList) - end, - asn1ct_name:new(tmpval), - emit(["Extensions = ", - {call,Erule,fixextensions,[{asis,Ext},{curr,val}]}, - com,nl]); - _ -> true - end, - EncObj = + ExtImm = case Ext of + {ext,ExtPos,NumExt} when NumExt > 0 -> + gen_encode_extaddgroup(CompList), + Value = asn1ct_gen:mk_var(asn1ct_name:curr(val)), + asn1ct_imm:per_enc_extensions(Value, ExtPos, + NumExt, Aligned); + _ -> + [] + end, + {EncObj,ObjSetImm} = case TableConsInfo of #simpletableattributes{usedclassfield=Used, uniqueclassfield=Unique} when Used /= Unique -> - false; + {false,[]}; %% ObjectSet, name of the object set in constraints %% %%{ObjectSet,AttrN,N,UniqueFieldName} -> %% N is index of attribute that determines constraint @@ -152,13 +117,10 @@ gen_encode_constructed(Erule,Typename,D) when is_record(D,type) -> asn1ct_gen:un_hyphen_var(lists:concat(['Obj',AttrN])), El = make_element(N+1, asn1ct_gen:mk_var(asn1ct_name:curr(val))), ValueMatch = value_match(ValueIndex, El), - emit([ObjectEncode," =",nl, - " ",{asis,Module},":'getenc_",ObjSetName,"'(", - {asis,UniqueFieldName},", ",nl, - " ",ValueMatch,"),",nl]), - {AttrN,ObjectEncode}; + ObjSetImm0 = [{assign,{var,ObjectEncode},ValueMatch}], + {{AttrN,ObjectEncode},ObjSetImm0}; false -> - false + {false,[]} end; _ -> case D#type.tablecinf of @@ -166,34 +128,52 @@ gen_encode_constructed(Erule,Typename,D) when is_record(D,type) -> %% when the simpletableattributes was at an outer %% level and the objfun has been passed through the %% function call - {"got objfun through args","ObjFun"}; + {{"got objfun through args","ObjFun"},[]}; _ -> - false + {false,[]} end end, - emit({"[",nl}), - MaybeComma1 = + ImmSetExt = case Ext of - {ext,_Pos,NumExt2} when NumExt2 > 0 -> - call(Erule, setext, ["Extensions =/= []"]), - ", "; - {ext,_Pos,_} -> - call(Erule, setext, ["false"]), - ", "; - _ -> - "" - end, - MaybeComma2 = - case optionals(CompList) of - [] -> MaybeComma1; - _ -> - emit(MaybeComma1), - emit("Opt"), - {",",nl} + {ext,_Pos,NumExt2} when NumExt2 > 0 -> + asn1ct_imm:per_enc_extension_bit('Extensions', Aligned); + {ext,_Pos,_} -> + asn1ct_imm:per_enc_extension_bit([], Aligned); + _ -> + [] end, - gen_enc_components_call(Erule,Typename,CompList,MaybeComma2,EncObj,Ext), - emit({"].",nl}). + ImmBody = gen_enc_components_call(Erule, Typename, CompList, EncObj, Ext), + ExternalImm ++ ExtImm ++ ObjSetImm ++ + asn1ct_imm:enc_append([ImmSetExt] ++ ImmOptionals ++ ImmBody). + +gen_encode_extaddgroup(CompList) -> + case extgroup_pos_and_length(CompList) of + {extgrouppos,[]} -> + ok; + {extgrouppos,ExtGroupPosLenList} -> + _ = [do_gen_encode_extaddgroup(G) || G <- ExtGroupPosLenList], + ok + end. +do_gen_encode_extaddgroup({ActualGroupPos,GroupVirtualPos,GroupLen}) -> + Val = asn1ct_gen:mk_var(asn1ct_name:curr(val)), + Elements = make_elements(GroupVirtualPos+1, + Val, + lists:seq(1, GroupLen)), + Expr = any_non_value(GroupVirtualPos+1, Val, GroupLen, ""), + emit([{next,val}," = case ",Expr," of",nl, + "false -> setelement(",{asis,ActualGroupPos+1},", ", + {curr,val},", asn1_NOVALUE);",nl, + "true -> setelement(",{asis,ActualGroupPos+1},", ", + {curr,val},", {extaddgroup,", Elements,"})",nl, + "end,",nl]), + asn1ct_name:new(val). + +any_non_value(_, _, 0, _) -> + []; +any_non_value(Pos, Val, N, Sep) -> + Sep ++ [make_element(Pos, Val)," =/= asn1_NOVALUE"] ++ + any_non_value(Pos+1, Val, N-1, [" orelse",nl]). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% generate decode function for SEQUENCE and SET @@ -328,28 +308,29 @@ gen_dec_constructed_imm(Erule, Typename, #type{}=D) -> EmitComp = gen_dec_components_call(Erule, Typename, CompList, DecObjInf, Ext, length(Optionals)), EmitRest = fun({AccTerm,AccBytes}) -> - gen_dec_constructed_imm_2(Typename, CompList, + gen_dec_constructed_imm_2(Erule, Typename, + CompList, ObjSetInfo, AccTerm, AccBytes) end, [EmitExt,EmitOpt|EmitComp++[{safe,EmitRest}]]. -gen_dec_constructed_imm_2(Typename, CompList, +gen_dec_constructed_imm_2(Erule, Typename, CompList, ObjSetInfo, AccTerm, AccBytes) -> - {_,UniqueFName,ValueIndex} = ObjSetInfo, + {_,_UniqueFName,ValueIndex} = ObjSetInfo, case {AccTerm,AccBytes} of {[],[]} -> ok; {_,[]} -> ok; {[{ObjSet,LeadingAttr,Term}],ListOfOpenTypes} -> - DecObj = asn1ct_gen:un_hyphen_var(lists:concat(['DecObj',LeadingAttr,Term])), - ValueMatch = value_match(ValueIndex,Term), - {ObjSetMod,ObjSetName} = ObjSet, - emit([DecObj," =",nl, - " ",{asis,ObjSetMod},":'getdec_",ObjSetName,"'(", - {asis,UniqueFName},", ",ValueMatch,"),",nl]), - gen_dec_listofopentypes(DecObj,ListOfOpenTypes,false) + ValueMatch = value_match(ValueIndex, Term), + _ = [begin + gen_dec_open_type(Erule, ValueMatch, ObjSet, + LeadingAttr, T), + emit([com,nl]) + end || T <- ListOfOpenTypes], + ok end, %% we don't return named lists any more Cnames = mkcnamelist(CompList), demit({"Result = "}), %dbg @@ -423,67 +404,143 @@ to_textual_order(Cs) when is_list(Cs) -> to_textual_order(Cs) -> Cs. -gen_dec_listofopentypes(_,[],_) -> - emit(nl); -gen_dec_listofopentypes(DecObj,[{_Cname,{FirstPFN,PFNList},Term,TmpTerm,Prop}|Rest],_Update) -> - - asn1ct_name:new(tmpterm), - asn1ct_name:new(reason), - - emit([Term," = ",nl]), +gen_dec_open_type(Erule, Val, {Xmod,Xtype}, LeadingAttr, + {_,{Name,RestFieldNames},Term,TmpTerm,Prop}) -> + #typedef{typespec=ObjSet0} = asn1_db:dbget(Xmod, Xtype), + #'ObjectSet'{class=Class,set=ObjSet1} = ObjSet0, + #'Externaltypereference'{module=ClMod,type=ClType} = Class, + #classdef{typespec=ClassDef} = asn1_db:dbget(ClMod, ClType), + #objectclass{fields=ClassFields} = ClassDef, + Extensible = lists:member('EXTENSIONMARK', ObjSet1), + ObjSet2 = [{Key,fix_object_code(Name, Code, ClassFields)} || + {_,Key,Code} <- ObjSet1], + ObjSet = lists:sort([P || {_,B}=P <- ObjSet2, B =/= none]), + Key = erlang:md5(term_to_binary({decode,ObjSet,RestFieldNames, + Prop,Extensible})), + Typename = [Name,ClType], + Gen = fun(_Fd, N) -> + dec_objset_optional(N, Prop), + dec_objset(Erule, N, ObjSet, RestFieldNames, Typename), + dec_objset_default(N, Name, LeadingAttr, Extensible) + end, + Prefix = lists:concat(["dec_os_",Name]), + F = asn1ct_func:call_gen(Prefix, Key, Gen), + emit([Term," = ",{asis,F},"(",TmpTerm,", ",Val,")"]). + +dec_objset_optional(N, {'DEFAULT',Val}) -> + dec_objset_optional_1(N, Val), + dec_objset_optional_1(N, asn1_DEFAULT); +dec_objset_optional(N, 'OPTIONAL') -> + dec_objset_optional_1(N, asn1_NOVALUE); +dec_objset_optional(_N, mandatory) -> ok. + +dec_objset_optional_1(N, Val) -> + emit([{asis,N},"(",{asis,Val},", _Id) ->",nl, + {asis,Val},";",nl]). + +dec_objset(_Erule, _N, [], _, _) -> + ok; +dec_objset(Erule, N, [Obj|Objs], RestFields, Cl) -> + dec_objset_1(Erule, N, Obj, RestFields, Cl), + emit([";",nl]), + dec_objset(Erule, N, Objs, RestFields, Cl). + +dec_objset_default(N, C, LeadingAttr, false) -> + emit([{asis,N},"(Bytes, Id) ->",nl, + "exit({'Type not compatible with table constraint'," + "{{component,",{asis,C},"}," + "{value,Bytes}," + "{unique_name_and_value,",{asis,LeadingAttr},",Id}}}).",nl,nl]); +dec_objset_default(N, _, _, true) -> + emit([{asis,N},"(Bytes, Id) ->",nl, + "Bytes.",nl,nl]). + +dec_objset_1(Erule, N, {Id,Obj}, RestFields, Typename) -> + emit([{asis,N},"(Bytes, ",{asis,Id},") ->",nl]), + dec_objset_2(Erule, Obj, RestFields, Typename). + +dec_objset_2(Erule, Obj, RestFields0, Typename) -> + case Obj of + #typedef{name={primitive,bif},typespec=Type} -> + Imm = asn1ct_gen_per:gen_dec_imm(Erule, Type), + {Term,_} = asn1ct_imm:dec_slim_cg(Imm, 'Bytes'), + emit([com,nl,Term]); + #typedef{name={constructed,bif},typespec=Def} -> + InnerType = asn1ct_gen:get_inner(Def#type.def), + case InnerType of + 'CHOICE' -> + asn1ct_name:start(), + asn1ct_name:new(bytes), + {'CHOICE',CompList} = Def#type.def, + Ext = extensible_enc(CompList), + emit(["{Result,_} = begin",nl]), + gen_dec_choice(Erule, Typename, CompList, Ext), + emit([nl, + "end",com,nl, + "Result"]); + 'SET' -> + Imm0 = gen_dec_constructed_imm(Erule, Typename, Def), + Imm = opt_imm(Imm0), + asn1ct_name:start(), + emit(["{Result,_} = begin",nl]), + emit_gen_dec_imm(Imm), + emit([nl, + "end",com,nl, + "Result"]); + 'SET OF' -> + asn1ct_name:start(), + do_gen_decode_sof(Erule, Typename, 'SET OF', + Def, false); + 'SEQUENCE' -> + Imm0 = gen_dec_constructed_imm(Erule, Typename, Def), + Imm = opt_imm(Imm0), + asn1ct_name:start(), + emit(["{Result,_} = begin",nl]), + emit_gen_dec_imm(Imm), + emit([nl, + "end",com,nl, + "Result"]); + 'SEQUENCE OF' -> + asn1ct_name:start(), + do_gen_decode_sof(Erule, Typename, 'SEQUENCE OF', + Def, false) + end; + #typedef{name=Type} -> + emit(["{Result,_} = ",{asis,enc_func("dec_", Type)},"(Bytes),",nl, + "Result"]); + #'Externaltypereference'{module=Mod,type=Type} -> + emit("{Term,_} = "), + Func = enc_func("dec_", Type), + case get(currmod) of + Mod -> + emit([{asis,Func},"(Bytes)"]); + _ -> + emit([{asis,Mod},":",{asis,Func},"(Bytes)"]) + end, + emit([com,nl, + "Term"]); + #'Externalvaluereference'{module=Mod,value=Value} -> + case asn1_db:dbget(Mod, Value) of + #typedef{typespec=#'Object'{def=Def}} -> + {object,_,Fields} = Def, + [NextField|RestFields] = RestFields0, + {NextField,Typedef} = lists:keyfind(NextField, 1, Fields), + dec_objset_2(Erule, Typedef, RestFields, Typename) + end + end. - N = case Prop of - mandatory -> 0; - 'OPTIONAL' -> - emit_opt_or_mand_check(asn1_NOVALUE,TmpTerm), - 6; - {'DEFAULT',Val} -> - emit_opt_or_mand_check(Val,TmpTerm), - 6 - end, +gen_encode_choice(Erule, TopType, D) -> + asn1ct_name:start(), + Imm = gen_encode_choice_imm(Erule, TopType, D), + asn1ct_imm:enc_cg(Imm, is_aligned(Erule)), + emit([".",nl]). - emit([indent(N+3),"case (catch ",DecObj,"(", - {asis,FirstPFN},", ",TmpTerm,", telltype,",{asis,PFNList},")) of",nl]), - emit([indent(N+6),"{'EXIT', ",{curr,reason},"} ->",nl]), - emit([indent(N+9),"exit({'Type not compatible with table constraint',", - {curr,reason},"});",nl]), - emit([indent(N+6),"{",{curr,tmpterm},",_} ->",nl]), - emit([indent(N+9),{curr,tmpterm},nl]), - - case Prop of - mandatory -> - emit([indent(N+3),"end,",nl]); - _ -> - emit([indent(N+3),"end",nl, - indent(3),"end,",nl]) - end, - gen_dec_listofopentypes(DecObj,Rest,true). - - -emit_opt_or_mand_check(Val,Term) -> - emit([indent(3),"case ",Term," of",nl, - indent(6),{asis,Val}," ->",{asis,Val},";",nl, - indent(6),"_ ->",nl]). - -%% ENCODE GENERATOR FOR THE CHOICE TYPE ******* -%% assume Val = {Alternative,AltType} -%% generate -%%[ -%% ?RT_PER:set_choice(element(1,Val),Altnum,Altlist,ext), -%%case element(1,Val) of -%% alt1 -> -%% encode_alt1(element(2,Val)); -%% alt2 -> -%% encode_alt2(element(2,Val)) -%%end -%%]. - -gen_encode_choice(Erule,Typename,D) when is_record(D,type) -> - {'CHOICE',CompList} = D#type.def, - emit({"[",nl}), +gen_encode_choice_imm(Erule, TopType, #type{def={'CHOICE',CompList}}) -> Ext = extensible_enc(CompList), - gen_enc_choice(Erule,Typename,CompList,Ext), - emit({nl,"].",nl}). + Aligned = is_aligned(Erule), + Cs = gen_enc_choice(Erule, TopType, CompList, Ext), + [{assign,{expr,"{ChoiceTag,ChoiceVal}"},"Val"}| + asn1ct_imm:per_enc_choice('ChoiceTag', Cs, Aligned)]. gen_decode_choice(Erules,Typename,D) when is_record(D,type) -> asn1ct_name:start(), @@ -496,72 +553,48 @@ gen_decode_choice(Erules,Typename,D) when is_record(D,type) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Encode generator for SEQUENCE OF type - -gen_encode_sof(Erule,Typename,SeqOrSetOf,D) when is_record(D,type) -> +gen_encode_sof(Erule, Typename, SeqOrSetOf, D) -> asn1ct_name:start(), - {_SeqOrSetOf,ComponentType} = D#type.def, - emit({"[",nl}), - SizeConstraint = asn1ct_imm:effective_constraint(bitstring, - D#type.constraint), - ObjFun = - case D#type.tablecinf of - [{objfun,_}|_R] -> - ", ObjFun"; - _-> - "" - end, - gen_encode_length(Erule, SizeConstraint), - emit({indent(3),"'enc_",asn1ct_gen:list2name(Typename), - "_components'(Val",ObjFun,", [])"}), - emit({nl,"].",nl}), - gen_encode_sof_components(Erule, Typename, SeqOrSetOf, ComponentType). - - -%% Logic copied from asn1_per_bin_rt2ct:encode_constrained_number -gen_encode_length(per, {Lb,Ub}) when Ub =< 65535, Lb >= 0 -> - Range = Ub - Lb + 1, - V2 = ["(length(Val) - ",Lb,")"], - Encode = if - Range == 1 -> - "[]"; - Range == 2 -> - {"[",V2,"]"}; - Range =< 4 -> - {"[10,2,",V2,"]"}; - Range =< 8 -> - {"[10,3,",V2,"]"}; - Range =< 16 -> - {"[10,4,",V2,"]"}; - Range =< 32 -> - {"[10,5,",V2,"]"}; - Range =< 64 -> - {"[10,6,",V2,"]"}; - Range =< 128 -> - {"[10,7,",V2,"]"}; - Range =< 255 -> - {"[10,8,",V2,"]"}; - Range =< 256 -> - {"[20,1,",V2,"]"}; - Range =< 65536 -> - {"[20,2,<<",V2,":16>>]"}; - true -> - {call,per,encode_length, - [{asis,{Lb,Ub}},"length(Val)"]} - end, - emit({nl,Encode,",",nl}); -gen_encode_length(Erules, SizeConstraint) -> - emit([nl,indent(3), - case SizeConstraint of - no -> - {call,Erules,encode_length,["length(Val)"]}; - _ -> - {call,Erules,encode_length, - [{asis,SizeConstraint},"length(Val)"]} - end, - com,nl]). + Imm = gen_encode_sof_imm(Erule, Typename, SeqOrSetOf, D), + asn1ct_imm:enc_cg(Imm, is_aligned(Erule)), + emit([".",nl,nl]). -gen_decode_sof(Erules,Typename,SeqOrSetOf,D) when is_record(D,type) -> +gen_encode_sof_imm(Erule, Typename, SeqOrSetOf, #type{}=D) -> + {_SeqOrSetOf,ComponentType} = D#type.def, + Aligned = is_aligned(Erule), + Constructed_Suffix = + asn1ct_gen:constructed_suffix(SeqOrSetOf, + ComponentType#type.def), + Conttype = asn1ct_gen:get_inner(ComponentType#type.def), + Currmod = get(currmod), + Imm0 = case asn1ct_gen:type(Conttype) of + {primitive,bif} -> + asn1ct_gen_per:gen_encode_prim_imm('Comp', ComponentType, Aligned); + {constructed,bif} -> + TypeName = [Constructed_Suffix|Typename], + Enc = enc_func(asn1ct_gen:list2name(TypeName)), + ObjArg = case D#type.tablecinf of + [{objfun,_}|_] -> [{var,"ObjFun"}]; + _ -> [] + end, + [{apply,Enc,[{var,"Comp"}|ObjArg]}]; + #'Externaltypereference'{module=Currmod,type=Ename} -> + [{apply,enc_func(Ename),[{var,"Comp"}]}]; + #'Externaltypereference'{module=EMod,type=Ename} -> + [{apply,{EMod,enc_func(Ename)},[{var,"Comp"}]}]; + 'ASN1_OPEN_TYPE' -> + asn1ct_gen_per:gen_encode_prim_imm('Comp', + #type{def='ASN1_OPEN_TYPE'}, + Aligned) + end, + asn1ct_imm:per_enc_sof('Val', D#type.constraint, 'Comp', Imm0, Aligned). + +gen_decode_sof(Erules, Typename, SeqOrSetOf, #type{}=D) -> asn1ct_name:start(), + do_gen_decode_sof(Erules, Typename, SeqOrSetOf, D, true), + emit([".",nl,nl]). + +do_gen_decode_sof(Erules, Typename, SeqOrSetOf, D, NeedRest) -> {_SeqOrSetOf,ComponentType} = D#type.def, SizeConstraint = asn1ct_imm:effective_constraint(bitstring, D#type.constraint), @@ -573,10 +606,16 @@ gen_decode_sof(Erules,Typename,SeqOrSetOf,D) when is_record(D,type) -> "" end, {Num,Buf} = gen_decode_length(SizeConstraint, Erules), + Key = erlang:md5(term_to_binary({Typename,SeqOrSetOf, + ComponentType,NeedRest})), + Gen = fun(_Fd, Name) -> + gen_decode_sof_components(Erules, Name, + Typename, SeqOrSetOf, + ComponentType, NeedRest) + end, + F = asn1ct_func:call_gen("dec_components", Key, Gen), emit([",",nl, - "'dec_",asn1ct_gen:list2name(Typename), - "_components'(",Num,", ",Buf,ObjFun,", []).",nl,nl]), - gen_decode_sof_components(Erules, Typename, SeqOrSetOf, ComponentType). + {asis,F},"(",Num,", ",Buf,ObjFun,", [])"]). is_aligned(per) -> true; is_aligned(uper) -> false. @@ -586,7 +625,7 @@ gen_decode_length(Constraint, Erule) -> Imm = asn1ct_imm:per_dec_length(Constraint, true, is_aligned(Erule)), asn1ct_imm:dec_slim_cg(Imm, "Bytes"). -gen_encode_sof_components(Erule,Typename,SeqOrSetOf,Cont) -> +gen_decode_sof_components(Erule, Name, Typename, SeqOrSetOf, Cont, NeedRest) -> {ObjFun,ObjFun_Var} = case Cont#type.tablecinf of [{objfun,_}|_R] -> @@ -594,76 +633,38 @@ gen_encode_sof_components(Erule,Typename,SeqOrSetOf,Cont) -> _ -> {"",""} end, - emit({"'enc_",asn1ct_gen:list2name(Typename),"_components'([]", - ObjFun_Var,", Acc) -> lists:reverse(Acc);",nl,nl}), - emit({"'enc_",asn1ct_gen:list2name(Typename),"_components'([H|T]", - ObjFun,", Acc) ->",nl}), - emit({"'enc_",asn1ct_gen:list2name(Typename),"_components'(T"}), - emit({ObjFun,", ["}), - %% the component encoder - Constructed_Suffix = asn1ct_gen:constructed_suffix(SeqOrSetOf, - Cont#type.def), - - Conttype = asn1ct_gen:get_inner(Cont#type.def), - Currmod = get(currmod), - case asn1ct_gen:type(Conttype) of - {primitive,bif} -> - asn1ct_gen_per:gen_encode_prim(Erule, Cont, "H"); - {constructed,bif} -> - NewTypename = [Constructed_Suffix|Typename], - emit({"'enc_",asn1ct_gen:list2name(NewTypename),"'(H", - ObjFun,")",nl,nl}); - #'Externaltypereference'{module=Currmod,type=Ename} -> - emit({"'enc_",Ename,"'(H)",nl,nl}); - #'Externaltypereference'{module=EMod,type=EType} -> - emit({"'",EMod,"':'enc_",EType,"'(H)",nl,nl}); - 'ASN1_OPEN_TYPE' -> - asn1ct_gen_per:gen_encode_prim(Erule, - #type{def='ASN1_OPEN_TYPE'}, - "H"); - _ -> - emit({"'enc_",Conttype,"'(H)",nl,nl}) + case NeedRest of + false -> + emit([{asis,Name},"(0, _Bytes",ObjFun_Var,", Acc) ->",nl, + "lists:reverse(Acc);",nl]); + true -> + emit([{asis,Name},"(0, Bytes",ObjFun_Var,", Acc) ->",nl, + "{lists:reverse(Acc),Bytes};",nl]) end, - emit({" | Acc]).",nl}). - -gen_decode_sof_components(Erule,Typename,SeqOrSetOf,Cont) -> - {ObjFun,ObjFun_Var} = - case Cont#type.tablecinf of - [{objfun,_}|_R] -> - {", ObjFun",", _"}; - _ -> - {"",""} - end, - emit({"'dec_",asn1ct_gen:list2name(Typename), - "_components'(0, Bytes",ObjFun_Var,", Acc) ->",nl, - indent(3),"{lists:reverse(Acc), Bytes};",nl}), - emit({"'dec_",asn1ct_gen:list2name(Typename), - "_components'(Num, Bytes",ObjFun,", Acc) ->",nl}), - emit({indent(3),"{Term,Remain} = "}), + emit([{asis,Name},"(Num, Bytes",ObjFun,", Acc) ->",nl, + "{Term,Remain} = "]), Constructed_Suffix = asn1ct_gen:constructed_suffix(SeqOrSetOf, Cont#type.def), Conttype = asn1ct_gen:get_inner(Cont#type.def), - Ctgenmod = asn1ct_gen:ct_gen_module(Erule), case asn1ct_gen:type(Conttype) of {primitive,bif} -> - Ctgenmod:gen_dec_prim(Erule,Cont,"Bytes"), + asn1ct_gen_per:gen_dec_prim(Erule, Cont, "Bytes"), emit({com,nl}); {constructed,bif} -> NewTypename = [Constructed_Suffix|Typename], emit({"'dec_",asn1ct_gen:list2name(NewTypename), - "'(Bytes, telltype",ObjFun,"),",nl}); + "'(Bytes",ObjFun,"),",nl}); #'Externaltypereference'{}=Etype -> asn1ct_gen_per:gen_dec_external(Etype, "Bytes"), emit([com,nl]); 'ASN1_OPEN_TYPE' -> - Ctgenmod:gen_dec_prim(Erule,#type{def='ASN1_OPEN_TYPE'}, - "Bytes"), + asn1ct_gen_per:gen_dec_prim(Erule, #type{def='ASN1_OPEN_TYPE'}, + "Bytes"), emit({com,nl}); _ -> - emit({"'dec_",Conttype,"'(Bytes,telltype),",nl}) + emit({"'dec_",Conttype,"'(Bytes),",nl}) end, - emit({indent(3),"'dec_",asn1ct_gen:list2name(Typename), - "_components'(Num-1, Remain",ObjFun,", [Term|Acc]).",nl}). + emit([{asis,Name},"(Num-1, Remain",ObjFun,", [Term|Acc]).",nl]). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -754,27 +755,6 @@ gen_dec_optionals(Optionals) -> end, {imm,Imm0,E}. -gen_fixoptionals([{Pos,Def}|R]) -> - asn1ct_name:new(fixopt), - emit({{curr,fixopt}," = case element(",{asis,Pos},",",{curr,val},") of",nl, - "asn1_DEFAULT -> 0;",nl, - {asis,Def}," -> 0;",nl, - "_ -> 1",nl, - "end,",nl}), - gen_fixoptionals(R); -gen_fixoptionals([Pos|R]) -> - gen_fixoptionals([{Pos,asn1_NOVALUE}|R]); -gen_fixoptionals([]) -> - ok. - - -param_map(Fun, [H]) -> - [Fun(H)]; -param_map(Fun, [H|T]) -> - [Fun(H),","|param_map(Fun,T)]. - - - %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% Produce a list with positions (in the Value record) where %% there are optional components, start with 2 because first element @@ -788,15 +768,13 @@ optionals({L1,Ext,L2}) -> optionals({L,_Ext}) -> optionals(L,[],2); optionals(L) -> optionals(L,[],2). -optionals([{'EXTENSIONMARK',_,_}|Rest],Acc,Pos) -> - optionals(Rest,Acc,Pos); % optionals in extension are currently not handled -optionals([#'ComponentType'{prop='OPTIONAL'}|Rest],Acc,Pos) -> - optionals(Rest,[Pos|Acc],Pos+1); -optionals([#'ComponentType'{prop={'DEFAULT',Val}}|Rest],Acc,Pos) -> - optionals(Rest,[{Pos,Val}|Acc],Pos+1); -optionals([#'ComponentType'{}|Rest],Acc,Pos) -> - optionals(Rest,Acc,Pos+1); -optionals([],Acc,_) -> +optionals([#'ComponentType'{prop='OPTIONAL'}|Rest], Acc, Pos) -> + optionals(Rest, [Pos|Acc], Pos+1); +optionals([#'ComponentType'{prop={'DEFAULT',Val}}|Rest], Acc, Pos) -> + optionals(Rest, [{Pos,Val}|Acc], Pos+1); +optionals([#'ComponentType'{}|Rest], Acc, Pos) -> + optionals(Rest, Acc, Pos+1); +optionals([], Acc, _) -> lists:reverse(Acc). %%%%%%%%%%%%%%%%%%%%%% @@ -858,33 +836,32 @@ add_textual_order1(Cs,NumIn) -> end, NumIn,Cs). -gen_enc_components_call(Erule,TopType,{Root,ExtList},MaybeComma,DynamicEnc,Ext) -> - gen_enc_components_call(Erule,TopType,{Root,ExtList,[]},MaybeComma,DynamicEnc,Ext); -gen_enc_components_call(Erule,TopType,CL={Root,ExtList,Root2},MaybeComma,DynamicEnc,Ext) -> +gen_enc_components_call(Erule,TopType,{Root,ExtList}, DynamicEnc,Ext) -> + gen_enc_components_call(Erule,TopType,{Root,ExtList,[]}, DynamicEnc,Ext); +gen_enc_components_call(Erule,TopType,CL={Root,ExtList,Root2}, DynamicEnc,Ext) -> %% The type has extensionmarker - Rpos = gen_enc_components_call1(Erule,TopType,Root++Root2,1,MaybeComma,DynamicEnc,noext), - case Ext of - {ext,_,ExtNum} when ExtNum > 0 -> - emit([nl, - ",Extensions",nl]); - - _ -> true - end, + {Imm0,Rpos} = gen_enc_components_call1(Erule,TopType,Root++Root2,1, DynamicEnc,noext,[]), + ExtImm = case Ext of + {ext,_,ExtNum} when ExtNum > 0 -> + [{var,"Extensions"}]; + _ -> + [] + end, %handle extensions {extgrouppos,ExtGroupPosLen} = extgroup_pos_and_length(CL), NewExtList = wrap_extensionAdditionGroups(ExtList,ExtGroupPosLen), - gen_enc_components_call1(Erule,TopType,NewExtList,Rpos,MaybeComma,DynamicEnc,Ext); -gen_enc_components_call(Erule,TopType, CompList, MaybeComma, DynamicEnc, Ext) -> + {Imm1,_} = gen_enc_components_call1(Erule,TopType,NewExtList,Rpos,DynamicEnc,Ext,[]), + Imm0 ++ [ExtImm|Imm1]; +gen_enc_components_call(Erule,TopType, CompList, DynamicEnc, Ext) -> %% The type has no extensionmarker - gen_enc_components_call1(Erule,TopType,CompList,1,MaybeComma,DynamicEnc,Ext). + {Imm,_} = gen_enc_components_call1(Erule,TopType,CompList,1,DynamicEnc,Ext,[]), + Imm. gen_enc_components_call1(Erule,TopType, [C=#'ComponentType'{name=Cname,typespec=Type,prop=Prop}|Rest], Tpos, - MaybeComma, DynamicEnc, Ext) -> + DynamicEnc, Ext, Acc) -> - put(component_type,{true,C}), - %% information necessary in asn1ct_gen_per_rt2ct:gen_encode_prim TermNo = case C#'ComponentType'.textual_order of undefined -> @@ -892,90 +869,48 @@ gen_enc_components_call1(Erule,TopType, CanonicalNum -> CanonicalNum end, - emit(MaybeComma), - case Prop of - 'OPTIONAL' -> - gen_enc_component_optional(Erule,TopType,Cname,Type,TermNo,DynamicEnc,Ext); - {'DEFAULT',DefVal} -> - gen_enc_component_default(Erule,TopType,Cname,Type,TermNo,DynamicEnc,Ext,DefVal); + Element0 = make_element(TermNo+1, asn1ct_gen:mk_var(asn1ct_name:curr(val))), + {Imm0,Element} = asn1ct_imm:enc_bind_var(Element0), + Imm1 = gen_enc_line_imm(Erule, TopType, Cname, Type, Element, DynamicEnc, Ext), + Category = case {Prop,Ext} of + {'OPTIONAL',_} -> + optional; + {{'DEFAULT',DefVal},_} -> + {default,DefVal}; + {_,{ext,ExtPos,_}} when Tpos >= ExtPos -> + optional; + {_,_} -> + mandatory + end, + Imm2 = case Category of + mandatory -> + Imm1; + optional -> + asn1ct_imm:enc_absent(Element, [asn1_NOVALUE], Imm1); + {default,Def} -> + asn1ct_imm:enc_absent(Element, [asn1_DEFAULT,Def], Imm1) + end, + Imm = case Imm2 of + [] -> []; + _ -> Imm0 ++ Imm2 + end, + gen_enc_components_call1(Erule, TopType, Rest, Tpos+1, DynamicEnc, Ext, [Imm|Acc]); +gen_enc_components_call1(_Erule,_TopType,[],Pos,_,_, Acc) -> + ImmList = lists:reverse(Acc), + {ImmList,Pos}. + +gen_enc_line_imm(Erule, TopType, Cname, Type, Element, DynamicEnc, Ext) -> + Imm0 = gen_enc_line_imm_1(Erule, TopType, Cname, Type, + Element, DynamicEnc), + Aligned = is_aligned(Erule), + case Ext of + {ext,_Ep2,_} -> + asn1ct_imm:per_enc_open_type(Imm0, Aligned); _ -> - case Ext of - {ext,ExtPos,_} when Tpos >= ExtPos -> - gen_enc_component_optional(Erule,TopType,Cname,Type,TermNo,DynamicEnc,Ext); - _ -> - gen_enc_component_mandatory(Erule,TopType,Cname,Type,TermNo,DynamicEnc,Ext) - end - end, - - erase(component_type), + Imm0 + end. - case Rest of - [] -> - Tpos+1; - _ -> - emit({com,nl}), - gen_enc_components_call1(Erule,TopType,Rest,Tpos+1,"",DynamicEnc,Ext) - end; -gen_enc_components_call1(_Erule,_TopType,[],Pos,_,_,_) -> - Pos. - -gen_enc_component_default(Erule,TopType,Cname,Type,Pos,DynamicEnc,Ext,DefaultVal) -> - Element = make_element(Pos+1,asn1ct_gen:mk_var(asn1ct_name:curr(val))), - emit({"case ",Element," of",nl}), -% emit({"asn1_DEFAULT -> [];",nl}), - emit({"DFLT when DFLT == asn1_DEFAULT; DFLT == ",{asis,DefaultVal}," -> [];",nl}), - - asn1ct_name:new(tmpval), - emit({{curr,tmpval}," ->",nl}), - InnerType = asn1ct_gen:get_inner(Type#type.def), - emit({nl,"%% attribute number ",Pos," with type ", - InnerType,nl}), - NextElement = asn1ct_gen:mk_var(asn1ct_name:curr(tmpval)), - gen_enc_line(Erule,TopType,Cname,Type,NextElement, Pos,DynamicEnc,Ext), - emit({nl,"end"}). - -gen_enc_component_optional(Erule,TopType,Cname, - Type=#type{def=#'SEQUENCE'{ - extaddgroup=Number, - components=_ExtGroupCompList}}, - Pos,DynamicEnc,Ext) when is_integer(Number) -> - - Element = make_element(Pos+1,asn1ct_gen:mk_var(asn1ct_name:curr(val))), - emit({"case ",Element," of",nl}), - - emit({"asn1_NOVALUE -> [];",nl}), - asn1ct_name:new(tmpval), - emit({{curr,tmpval}," ->",nl}), - InnerType = asn1ct_gen:get_inner(Type#type.def), - emit({nl,"%% attribute number ",Pos," with type ", - InnerType,nl}), - NextElement = asn1ct_gen:mk_var(asn1ct_name:curr(tmpval)), - gen_enc_line(Erule,TopType,Cname,Type,NextElement, Pos,DynamicEnc,Ext), - emit({nl,"end"}); -gen_enc_component_optional(Erule,TopType,Cname,Type,Pos,DynamicEnc,Ext) -> - Element = make_element(Pos+1,asn1ct_gen:mk_var(asn1ct_name:curr(val))), - emit({"case ",Element," of",nl}), - - emit({"asn1_NOVALUE -> [];",nl}), - asn1ct_name:new(tmpval), - emit({{curr,tmpval}," ->",nl}), - InnerType = asn1ct_gen:get_inner(Type#type.def), - emit({nl,"%% attribute number ",Pos," with type ", - InnerType,nl}), - NextElement = asn1ct_gen:mk_var(asn1ct_name:curr(tmpval)), - gen_enc_line(Erule,TopType,Cname,Type,NextElement, Pos,DynamicEnc,Ext), - emit({nl,"end"}). - -gen_enc_component_mandatory(Erule,TopType,Cname,Type,Pos,DynamicEnc,Ext) -> - InnerType = asn1ct_gen:get_inner(Type#type.def), - emit({nl,"%% attribute number ",Pos," with type ", - InnerType,nl}), - gen_enc_line(Erule,TopType,Cname,Type,[],Pos,DynamicEnc,Ext). - -gen_enc_line(Erule,TopType, Cname, Type, [], Pos,DynamicEnc,Ext) -> - Element = make_element(Pos+1,asn1ct_gen:mk_var(asn1ct_name:curr(val))), - gen_enc_line(Erule,TopType,Cname,Type,Element, Pos,DynamicEnc,Ext); -gen_enc_line(Erule,TopType,Cname,Type,Element, _Pos,DynamicEnc,Ext) -> +gen_enc_line_imm_1(Erule, TopType, Cname, Type, Element, DynamicEnc) -> Atype = case Type of #type{def=#'ObjectClassFieldType'{type=InnerType}} -> @@ -983,81 +918,157 @@ gen_enc_line(Erule,TopType,Cname,Type,Element, _Pos,DynamicEnc,Ext) -> _ -> asn1ct_gen:get_inner(Type#type.def) end, - - case Ext of - {ext,_Ep1,_} -> - asn1ct_func:need({Erule,encode_open_type,1}), - asn1ct_func:need({Erule,complete,1}), - emit(["encode_open_type(complete("]); - _ -> true - end, - + Aligned = is_aligned(Erule), case Atype of {typefield,_} -> - case DynamicEnc of - {_LeadingAttrName,Fun} -> - case (Type#type.def)#'ObjectClassFieldType'.fieldname of - {Name,RestFieldNames} when is_atom(Name) -> - asn1ct_func:need({Erule,complete,1}), - asn1ct_func:need({Erule,encode_open_type,1}), - emit({"encode_open_type(complete(",nl}), - emit({" ",Fun,"(",{asis,Name},", ", - Element,", ",{asis,RestFieldNames},")))"}); - Other -> - throw({asn1,{'internal error',Other}}) - end - end; - {objectfield,PrimFieldName1,PFNList} -> - case DynamicEnc of - {_LeadingAttrName,Fun} -> - asn1ct_func:need({Erule,complete,1}), - asn1ct_func:need({Erule,encode_open_type,1}), - emit({"encode_open_type(" - "complete(",nl}), - emit({" ",Fun,"(",{asis,PrimFieldName1}, - ", ",Element,", ",{asis,PFNList},")))"}) + {_LeadingAttrName,Fun} = DynamicEnc, + case (Type#type.def)#'ObjectClassFieldType'.fieldname of + {Name,RestFieldNames} when is_atom(Name) -> + Imm = enc_var_type_call(Erule, Name, RestFieldNames, + Type, Fun, Element), + asn1ct_imm:per_enc_open_type(Imm, Aligned) end; _ -> CurrMod = get(currmod), case asn1ct_gen:type(Atype) of - #'Externaltypereference'{module=Mod,type=EType} when - (CurrMod==Mod) -> - emit({"'enc_",EType,"'(",Element,")"}); + #'Externaltypereference'{module=CurrMod,type=EType} -> + [{apply,enc_func(EType),[{expr,Element}]}]; #'Externaltypereference'{module=Mod,type=EType} -> - emit({"'",Mod,"':'enc_", - EType,"'(",Element,")"}); + [{apply,{Mod,enc_func(EType)},[{expr,Element}]}]; {primitive,bif} -> - asn1ct_gen_per:gen_encode_prim(Erule, Type, Element); + asn1ct_gen_per:gen_encode_prim_imm(Element, Type, Aligned); 'ASN1_OPEN_TYPE' -> case Type#type.def of #'ObjectClassFieldType'{type=OpenType} -> - asn1ct_gen_per:gen_encode_prim(Erule, - #type{def=OpenType}, - Element); + asn1ct_gen_per:gen_encode_prim_imm(Element, + #type{def=OpenType}, + Aligned); _ -> - asn1ct_gen_per:gen_encode_prim(Erule, Type, - Element) + asn1ct_gen_per:gen_encode_prim_imm(Element, + Type, + Aligned) end; {constructed,bif} -> NewTypename = [Cname|TopType], + Enc = enc_func(asn1ct_gen:list2name(NewTypename)), case {Type#type.tablecinf,DynamicEnc} of {[{objfun,_}|_R],{_,EncFun}} -> - emit({"'enc_", - asn1ct_gen:list2name(NewTypename), - "'(",Element,", ",EncFun,")"}); + [{apply,Enc,[{expr,Element},{var,EncFun}]}]; _ -> - emit({"'enc_", - asn1ct_gen:list2name(NewTypename), - "'(",Element,")"}) + [{apply,Enc,[{expr,Element}]}] end end - end, - case Ext of - {ext,_Ep2,_} -> - emit("))"); - _ -> true end. +enc_func(Type) -> + enc_func("enc_", Type). + +enc_func(Prefix, Name) -> + list_to_atom(lists:concat([Prefix,Name])). + +enc_var_type_call(Erule, Name, RestFieldNames, + #type{tablecinf=TCI}, Fun, Val) -> + [{objfun,#'Externaltypereference'{module=Xmod,type=Xtype}}] = TCI, + #typedef{typespec=ObjSet0} = asn1_db:dbget(Xmod, Xtype), + #'ObjectSet'{class=Class,set=ObjSet1} = ObjSet0, + #'Externaltypereference'{module=ClMod,type=ClType} = Class, + #classdef{typespec=ClassDef} = asn1_db:dbget(ClMod, ClType), + #objectclass{fields=ClassFields} = ClassDef, + Extensible = lists:member('EXTENSIONMARK', ObjSet1), + ObjSet2 = [{Key,fix_object_code(Name, Code, ClassFields)} || + {_,Key,Code} <- ObjSet1], + ObjSet = lists:sort([P || {_,B}=P <- ObjSet2, B =/= none]), + Key = erlang:md5(term_to_binary({encode,ObjSet,RestFieldNames,Extensible})), + Gen = fun(_Fd, N) -> + enc_objset(Erule, Name, N, ObjSet, + RestFieldNames, Extensible) + end, + Prefix = lists:concat(["enc_os_",Name]), + F = asn1ct_func:call_gen(Prefix, Key, Gen), + [{apply,F,[{var,atom_to_list(Val)},{var,Fun}]}]. + +fix_object_code(Name, [{Name,B}|_], _ClassFields) -> + B; +fix_object_code(Name, [_|T], ClassFields) -> + fix_object_code(Name, T, ClassFields); +fix_object_code(Name, [], ClassFields) -> + case lists:keyfind(Name, 2, ClassFields) of + {typefield,Name,'OPTIONAL'} -> + none; + {objectfield,Name,_,_,'OPTIONAL'} -> + none; + {typefield,Name,{'DEFAULT',#type{}=Type}} -> + InnerType = asn1ct_gen:get_inner(Type#type.def), + case asn1ct_gen:type(InnerType) of + {primitive,bif} -> + #typedef{name={primitive,bif},typespec=Type}; + {constructed,bif} -> + #typedef{name={constructed,bif},typespec=Type} + end + end. + + +enc_objset(Erule, Component, Name, ObjSet, RestFieldNames, Extensible) -> + asn1ct_name:start(), + Aligned = is_aligned(Erule), + E = {error, + fun() -> + emit(["exit({'Type not compatible with table constraint'," + "{component,",{asis,Component},"}," + "{value,Val}," + "{unique_name_and_value,'_'}})",nl]) + end}, + Imm = [{'cond', + [[{eq,{var,"Id"},Key}| + enc_obj(Erule, Obj, RestFieldNames, Aligned)] || + {Key,Obj} <- ObjSet] ++ + [['_',case Extensible of + false -> E; + true -> {put_bits,{var,"Val"},binary,[1]} + end]]}], + emit([{asis,Name},"(Val, Id) ->",nl]), + asn1ct_imm:enc_cg(Imm, Aligned), + emit([".",nl]). + +enc_obj(Erule, Obj, RestFieldNames0, Aligned) -> + case Obj of + #typedef{name={primitive,bif},typespec=Def} -> + asn1ct_gen_per:gen_encode_prim_imm('Val', Def, Aligned); + #typedef{name={constructed,bif},typespec=Def} -> + InnerType = asn1ct_gen:get_inner(Def#type.def), + case InnerType of + 'CHOICE' -> + gen_encode_choice_imm(Erule, name, Def); + 'SET' -> + gen_encode_constructed_imm(Erule, name, Def); + 'SET OF' -> + gen_encode_sof_imm(Erule, name, InnerType, Def); + 'SEQUENCE' -> + gen_encode_constructed_imm(Erule, name, Def); + 'SEQUENCE OF' -> + gen_encode_sof_imm(Erule, name, InnerType, Def) + end; + #typedef{name=Type} -> + [{apply,enc_func(Type),[{var,"Val"}]}]; + #'Externalvaluereference'{module=Mod,value=Value} -> + case asn1_db:dbget(Mod, Value) of + #typedef{typespec=#'Object'{def=Def}} -> + {object,_,Fields} = Def, + [NextField|RestFieldNames] = RestFieldNames0, + {NextField,Typedef} = lists:keyfind(NextField, 1, Fields), + enc_obj(Erule, Typedef, RestFieldNames, Aligned) + end; + #'Externaltypereference'{module=Mod,type=Type} -> + Func = enc_func(Type), + case get(currmod) of + Mod -> + [{apply,Func,[{var,"Val"}]}]; + _ -> + [{apply,{Mod,Func},[{var,"Val"}]}] + end + end. + + gen_dec_components_call(Erule, TopType, {Root,ExtList}, DecInfObj, Ext, NumberOfOptionals) -> gen_dec_components_call(Erule,TopType,{Root,ExtList,[]}, @@ -1163,14 +1174,6 @@ gen_dec_comp_call(Comp, Erule, TopType, Tpos, OptTable, DecInfObj, emit(["{",{curr,tmpterm},", ",{next,bytes},"} = "]), St end; - %%{objectfield,_,_} when Ext == noext, Prop == mandatory -> - {{objectfield,_,_},true} -> - fun(St) -> - asn1ct_name:new(term), - asn1ct_name:new(tmpterm), - emit(["{",{curr,tmpterm},", ",{next,bytes},"} = "]), - St - end; _ -> case Type of #type{def=#'SEQUENCE'{ @@ -1350,25 +1353,19 @@ gen_dec_line_special(Erule, {typefield,_}, _TopType, Comp, false -> % This is in a choice with typefield components {Name,RestFieldNames} = (Type#type.def)#'ObjectClassFieldType'.fieldname, - - asn1ct_name:new(reason), Imm = asn1ct_imm:per_dec_open_type(is_aligned(Erule)), BytesVar = asn1ct_gen:mk_var(asn1ct_name:curr(bytes)), {TmpTerm,TempBuf} = asn1ct_imm:dec_slim_cg(Imm, BytesVar), + emit([com,nl]), + #type{tablecinf=[{objfun, + #'Externaltypereference'{module=Xmod, + type=Xtype}}]} = + Type, + gen_dec_open_type(Erule, "ObjFun", {Xmod,Xtype}, + '_', {'_',{Name,RestFieldNames}, + 'Result',TmpTerm,mandatory}), emit([com,nl, - {next,bytes}," = ",TempBuf,com,nl, - indent(2),"case (catch ObjFun(", - {asis,Name},",",TmpTerm,",telltype,", - {asis,RestFieldNames},")) of", nl]), - emit([indent(4),"{'EXIT',",{curr,reason},"} ->",nl]), - emit([indent(6),"exit({'Type not ", - "compatible with table constraint', ", - {curr,reason},"});",nl]), - asn1ct_name:new(tmpterm), - emit([indent(4),"{",{curr,tmpterm},", _} ->",nl]), - emit([indent(6),"{",{asis,Cname},", {",{curr,tmpterm},", ", - {next,bytes},"}}",nl]), - emit([indent(2),"end"]), + "{",{asis,Cname},",{Result,",TempBuf,"}}"]), {[],PrevSt}; {"got objfun through args","ObjFun"} -> %% this is when the generated code gots the @@ -1388,27 +1385,22 @@ gen_dec_line_special(Erule, {typefield,_}, _TopType, Comp, BytesVar = asn1ct_gen:mk_var(asn1ct_name:curr(bytes)), asn1ct_imm:dec_code_gen(Imm, BytesVar), emit([com,nl]), + #type{tablecinf=[{objfun, + #'Externaltypereference'{module=Xmod, + type=Xtype}}]} = + Type, + Term = asn1ct_gen:mk_var(asn1ct_name:curr(term)), + TmpTerm = asn1ct_gen:mk_var(asn1ct_name:curr(tmpterm)), if Prop =:= mandatory -> - emit([{curr,term}," =",nl," "]); - true -> - emit([" {"]) - end, - emit(["case (catch ObjFun(",{asis,Name},",", - {curr,tmpterm},",telltype,", - {asis,RestFieldNames},")) of", nl]), - emit([" {'EXIT',",{curr,reason},"} ->",nl]), - emit([indent(6),"exit({'Type not ", - "compatible with table constraint', ", - {curr,reason},"});",nl]), - asn1ct_name:new(tmpterm), - emit([indent(4),"{",{curr,tmpterm},", _} ->",nl]), - emit([indent(6),{curr,tmpterm},nl]), - emit([indent(2),"end"]), - if - Prop =:= mandatory -> - ok; + gen_dec_open_type(Erule, "ObjFun", {Xmod,Xtype}, + '_', {'_',{Name,RestFieldNames}, + Term,TmpTerm,Prop}); true -> + emit([" {"]), + gen_dec_open_type(Erule, "ObjFun", {Xmod,Xtype}, + '_', {'_',{Name,RestFieldNames}, + '_',TmpTerm,Prop}), emit([",",nl,{curr,tmpbytes},"}"]) end, {[],PrevSt}; @@ -1425,19 +1417,6 @@ gen_dec_line_special(Erule, {typefield,_}, _TopType, Comp, Prop}],PrevSt} end end; -gen_dec_line_special(Erule, {objectfield,PrimFieldName1,PFNList}, _TopType, - Comp, _DecInfObj) -> - fun({_BytesVar,PrevSt}) -> - Imm = asn1ct_imm:per_dec_open_type(is_aligned(Erule)), - BytesVar = asn1ct_gen:mk_var(asn1ct_name:curr(bytes)), - asn1ct_imm:dec_code_gen(Imm, BytesVar), - #'ComponentType'{name=Cname,prop=Prop} = Comp, - SaveBytes = [{Cname,{PrimFieldName1,PFNList}, - asn1ct_gen:mk_var(asn1ct_name:curr(term)), - asn1ct_gen:mk_var(asn1ct_name:curr(tmpterm)), - Prop}], - {SaveBytes,PrevSt} - end; gen_dec_line_special(Erule, Atype, TopType, Comp, DecInfObj) -> case gen_dec_line_other(Erule, Atype, TopType, Comp) of Fun when is_function(Fun, 1) -> @@ -1458,14 +1437,11 @@ gen_dec_line_special(Erule, Atype, TopType, Comp, DecInfObj) -> gen_dec_line_dec_inf(Comp, DecInfObj) -> #'ComponentType'{name=Cname} = Comp, case DecInfObj of - {Cname,{_,OSet,UniqueFName,ValIndex}} -> + {Cname,{_,_OSet,_UniqueFName,ValIndex}} -> Term = asn1ct_gen:mk_var(asn1ct_name:curr(term)), ValueMatch = value_match(ValIndex,Term), - {ObjSetMod,ObjSetName} = OSet, emit([",",nl, - "ObjFun = ",{asis,ObjSetMod}, - ":'getdec_",ObjSetName,"'(", - {asis,UniqueFName},", ",ValueMatch,")"]); + "ObjFun = ",ValueMatch]); _ -> ok end. @@ -1492,63 +1468,35 @@ gen_dec_line_other(Erule, Atype, TopType, Comp) -> [{objfun,_}|_R] -> fun(BytesVar) -> emit({"'dec_",asn1ct_gen:list2name(NewTypename), - "'(",BytesVar,", telltype, ObjFun)"}) + "'(",BytesVar,", ObjFun)"}) end; _ -> fun(BytesVar) -> emit({"'dec_",asn1ct_gen:list2name(NewTypename), - "'(",BytesVar,", telltype)"}) + "'(",BytesVar,")"}) end end end. -gen_enc_choice(Erule,TopType,CompList,Ext) -> - gen_enc_choice_tag(Erule, CompList, [], Ext), - emit({com,nl}), - emit({"case element(1,Val) of",nl}), - gen_enc_choice2(Erule,TopType, CompList, Ext), - emit({nl,"end"}). - -gen_enc_choice_tag(Erule, {C1,C2}, _, _) -> - N1 = get_name_list(C1), - N2 = get_name_list(C2), - call(Erule,set_choice, - ["element(1, Val)", - {asis,{N1,N2}}, - {asis,{length(N1),length(N2)}}]); -gen_enc_choice_tag(Erule, {C1,C2,C3}, _, _) -> - N1 = get_name_list(C1), - N2 = get_name_list(C2), - N3 = get_name_list(C3), - Root = N1 ++ N3, - call(Erule,set_choice, - ["element(1, Val)", - {asis,{Root,N2}}, - {asis,{length(Root),length(N2)}}]); -gen_enc_choice_tag(Erule, C, _, _) -> - N = get_name_list(C), - call(Erule,set_choice, - ["element(1, Val)", - {asis,N},{asis,length(N)}]). - -get_name_list(L) -> - get_name_list(L,[]). - -get_name_list([#'ComponentType'{name=Name}|T], Acc) -> - get_name_list(T,[Name|Acc]); -get_name_list([], Acc) -> - lists:reverse(Acc). - - -gen_enc_choice2(Erule,TopType, {L1,L2}, Ext) -> - gen_enc_choice2(Erule, TopType, L1 ++ L2, 0, [], Ext); -gen_enc_choice2(Erule, TopType, {L1,L2,L3}, Ext) -> - gen_enc_choice2(Erule, TopType, L1 ++ L3 ++ L2, 0, [], Ext); -gen_enc_choice2(Erule,TopType, L, Ext) -> - gen_enc_choice2(Erule,TopType, L, 0, [], Ext). +gen_enc_choice(Erule, TopType, {Root,Exts}, Ext) -> + Constr = choice_constraint(Root), + gen_enc_choices(Root, Erule, TopType, 0, Constr, Ext) ++ + gen_enc_choices(Exts, Erule, TopType, 0, ext, Ext); +gen_enc_choice(Erule, TopType, {Root,Exts,[]}, Ext) -> + gen_enc_choice(Erule, TopType, {Root,Exts}, Ext); +gen_enc_choice(Erule, TopType, Root, Ext) when is_list(Root) -> + Constr = choice_constraint(Root), + gen_enc_choices(Root, Erule, TopType, 0, Constr, Ext). + +choice_constraint(L) -> + case length(L) of + 0 -> [{'SingleValue',0}]; + Len -> [{'ValueRange',{0,Len-1}}] + end. -gen_enc_choice2(Erule, TopType, [H|T], Pos, Sep0, Ext) -> +gen_enc_choices([H|T], Erule, TopType, Pos, Constr, Ext) -> #'ComponentType'{name=Cname,typespec=Type} = H, + Aligned = is_aligned(Erule), EncObj = case asn1ct_gen:get_constraint(Type#type.constraint, componentrelation) of @@ -1562,16 +1510,25 @@ gen_enc_choice2(Erule, TopType, [H|T], Pos, Sep0, Ext) -> _ -> {no_attr,"ObjFun"} end, - emit([Sep0,{asis,Cname}," ->",nl]), - DoExt = case Ext of - {ext,ExtPos,_} when Pos + 1 < ExtPos -> noext; - _ -> Ext + DoExt = case Constr of + ext -> Ext; + _ -> noext end, - gen_enc_line(Erule, TopType, Cname, Type, "element(2, Val)", - Pos+1, EncObj, DoExt), - Sep = [";",nl], - gen_enc_choice2(Erule, TopType, T, Pos+1, Sep, Ext); -gen_enc_choice2(_, _, [], _, _, _) -> ok. + Tag = case {Ext,Constr} of + {noext,_} -> + asn1ct_imm:per_enc_integer(Pos, Constr, Aligned); + {{ext,_,_},ext} -> + [{put_bits,1,1,[1]}| + asn1ct_imm:per_enc_small_number(Pos, Aligned)]; + {{ext,_,_},_} -> + [{put_bits,0,1,[1]}| + asn1ct_imm:per_enc_integer(Pos, Constr, Aligned)] + end, + Body = gen_enc_line_imm(Erule, TopType, Cname, Type, 'ChoiceVal', + EncObj, DoExt), + Imm = Tag ++ Body, + [{Cname,Imm}|gen_enc_choices(T, Erule, TopType, Pos+1, Constr, Ext)]; +gen_enc_choices([], _, _, _, _, _) -> []. %% Generate the code for CHOICE. If the CHOICE is extensible, %% the structure of the generated code is as follows: @@ -1704,9 +1661,6 @@ gen_dec_choice2(Erule, TopType, [H0|T], Pos, Sep0, Pre) -> gen_dec_choice2(Erule, TopType, T, Pos+1, Sep, Pre); gen_dec_choice2(_, _, [], _, _, _) -> ok. -indent(N) -> - lists:duplicate(N,32). % 32 = space - make_elements(I,Val,ExtCnames) -> make_elements(I,Val,ExtCnames,[]). @@ -1720,7 +1674,7 @@ make_elements(_I,_,[],Acc) -> lists:reverse(Acc). make_element(I, Val) -> - io_lib:format("element(~w,~s)", [I,Val]). + lists:flatten(io_lib:format("element(~w, ~s)", [I,Val])). emit_extaddgroupTerms(VarSeries,[_]) -> asn1ct_name:new(VarSeries), @@ -1787,6 +1741,3 @@ value_match1(Value,[],Acc,Depth) -> Acc ++ Value ++ lists:concat(lists:duplicate(Depth,")")); value_match1(Value,[{VI,_}|VIs],Acc,Depth) -> value_match1(Value,VIs,Acc++lists:concat(["element(",VI,","]),Depth+1). - -is_optimized(per) -> true; -is_optimized(uper) -> false. diff --git a/lib/asn1/src/asn1ct_eval_per.funcs b/lib/asn1/src/asn1ct_eval_per.funcs deleted file mode 100644 index a1ea5cd043..0000000000 --- a/lib/asn1/src/asn1ct_eval_per.funcs +++ /dev/null @@ -1,2 +0,0 @@ -{per,encode_constrained_number,2}. -{per,encode_small_number,1}. diff --git a/lib/asn1/src/asn1ct_eval_uper.funcs b/lib/asn1/src/asn1ct_eval_uper.funcs deleted file mode 100644 index 884a486f40..0000000000 --- a/lib/asn1/src/asn1ct_eval_uper.funcs +++ /dev/null @@ -1,2 +0,0 @@ -{uper,encode_constrained_number,2}. -{uper,encode_small_number,1}. diff --git a/lib/asn1/src/asn1ct_func.erl b/lib/asn1/src/asn1ct_func.erl index ab0dbcce8f..dbadedb683 100644 --- a/lib/asn1/src/asn1ct_func.erl +++ b/lib/asn1/src/asn1ct_func.erl @@ -19,7 +19,7 @@ %% -module(asn1ct_func). --export([start_link/0,need/1,call/3,generate/1]). +-export([start_link/0,need/1,call/3,call_gen/3,call_gen/4,generate/1]). -export([init/1,handle_call/3,handle_cast/2,terminate/2]). start_link() -> @@ -28,15 +28,33 @@ start_link() -> ok. call(M, F, Args) -> - MFA = {M,F,length(Args)}, + A = length(Args), + MFA = {M,F,A}, need(MFA), - asn1ct_gen:emit([F,"(",call_args(Args, ""),")"]). + case M of + binary -> + asn1ct_gen:emit(["binary:",F,"(",call_args(Args, ""),")"]); + _ -> + asn1ct_gen:emit([F,"(",call_args(Args, ""),")"]) + end. +need({binary,_,_}) -> + ok; +need({erlang,_,_}) -> + ok; need(MFA) -> asn1ct_rtt:assert_defined(MFA), cast({need,MFA}). +call_gen(Prefix, Key, Gen, Args) when is_function(Gen, 2) -> + F = req({gen_func,Prefix,Key,Gen}), + asn1ct_gen:emit([F,"(",call_args(Args, ""),")"]). + +call_gen(Prefix, Key, Gen) when is_function(Gen, 2) -> + req({gen_func,Prefix,Key,Gen}). + generate(Fd) -> + do_generate(Fd), Used0 = req(get_used), erase(?MODULE), Used = sofs:set(Used0, [mfa]), @@ -53,10 +71,13 @@ cast(Req) -> %%% Internal functions. --record(st, {used}). +-record(st, {used, %Used functions + gen, %Dynamically generated functions + gc=1 %Counter for generated functions + }). init([]) -> - St = #st{used=gb_sets:empty()}, + St = #st{used=gb_sets:empty(),gen=gb_trees:empty()}, {ok,St}. handle_cast({need,MFA}, #st{used=Used0}=St) -> @@ -69,7 +90,20 @@ handle_cast({need,MFA}, #st{used=Used0}=St) -> end. handle_call(get_used, _From, #st{used=Used}=St) -> - {stop,normal,gb_sets:to_list(Used),St}. + {stop,normal,gb_sets:to_list(Used),St}; +handle_call(get_gen, _From, #st{gen=G0}=St) -> + {L,G} = do_get_gen(gb_trees:to_list(G0), [], []), + {reply,L,St#st{gen=gb_trees:from_orddict(G)}}; +handle_call({gen_func,Prefix,Key,GenFun}, _From, #st{gen=G0,gc=Gc0}=St) -> + case gb_trees:lookup(Key, G0) of + none -> + Name = list_to_atom(Prefix ++ integer_to_list(Gc0)), + Gc = Gc0 + 1, + G = gb_trees:insert(Key, {Name,GenFun}, G0), + {reply,Name,St#st{gen=G,gc=Gc}}; + {value,{Name,_}} -> + {reply,Name,St} + end. terminate(_, _) -> ok. @@ -98,3 +132,22 @@ update_worklist([H|T], Used, Ws) -> update_worklist(T, Used, Ws) end; update_worklist([], _, Ws) -> Ws. + +do_get_gen([{_,{_,done}}=Keep|T], Gacc, Kacc) -> + do_get_gen(T, Gacc, [Keep|Kacc]); +do_get_gen([{K,{Name,_}=V}|T], Gacc, Kacc) -> + do_get_gen(T, [V|Gacc], [{K,{Name,done}}|Kacc]); +do_get_gen([], Gacc, Kacc) -> + {lists:sort(Gacc),lists:reverse(Kacc)}. + +do_generate(Fd) -> + case req(get_gen) of + [] -> + ok; + [_|_]=Gen -> + _ = [begin + ok = file:write(Fd, "\n"), + GenFun(Fd, Name) + end || {Name,GenFun} <- Gen], + do_generate(Fd) + end. diff --git a/lib/asn1/src/asn1ct_gen.erl b/lib/asn1/src/asn1ct_gen.erl index 9095e145a3..e6ec0cb12b 100644 --- a/lib/asn1/src/asn1ct_gen.erl +++ b/lib/asn1/src/asn1ct_gen.erl @@ -798,7 +798,12 @@ pgen_exports(Erules,_Module,{Types,Values,_,_,Objects,ObjectSets}) -> gen_exports1(Types,"enc_",1) end, emit({"-export([",nl}), - gen_exports1(Types,"dec_",2) + case Erules of + ber -> + gen_exports1(Types, "dec_", 2); + _ -> + gen_exports1(Types, "dec_", 1) + end end, case [X || {n2n,X} <- get(encoding_options)] of [] -> ok; @@ -819,10 +824,7 @@ pgen_exports(Erules,_Module,{Types,Values,_,_,Objects,ObjectSets}) -> _ -> case erule(Erules) of per -> - emit({"-export([",nl}), - gen_exports1(Objects,"enc_",3), - emit({"-export([",nl}), - gen_exports1(Objects,"dec_",4); + ok; ber -> emit({"-export([",nl}), gen_exports1(Objects,"enc_",3), @@ -833,10 +835,15 @@ pgen_exports(Erules,_Module,{Types,Values,_,_,Objects,ObjectSets}) -> case ObjectSets of [] -> ok; _ -> - emit({"-export([",nl}), - gen_exports1(ObjectSets,"getenc_",2), - emit({"-export([",nl}), - gen_exports1(ObjectSets,"getdec_",2) + case erule(Erules) of + per -> + ok; + ber -> + emit({"-export([",nl}), + gen_exports1(ObjectSets, "getenc_",1), + emit({"-export([",nl}), + gen_exports1(ObjectSets, "getdec_",1) + end end, emit({"-export([info/0]).",nl}), gen_partial_inc_decode_exports(), @@ -916,15 +923,23 @@ pgen_dispatcher(Erules,_Module,{Types,_Values,_,_,_Objects,_ObjectSets}) -> {["complete(encode_disp(Type, Data))"],"Bytes"} end, emit(["encode(Type,Data) ->",nl, - "case catch ",Call," of",nl, - " {'EXIT',{error,Reason}} ->",nl, - " {error,Reason};",nl, - " {'EXIT',Reason} ->",nl, - " {error,{asn1,Reason}};",nl, - " {Bytes,_Len} ->",nl, - " {ok,",BytesAsBinary,"};",nl, - " Bytes ->",nl, - " {ok,",BytesAsBinary,"}",nl, + "try ",Call," of",nl, + case erule(Erules) of + ber -> + [" {Bytes,_Len} ->",nl, + " {ok,",BytesAsBinary,"}",nl]; + per -> + [" Bytes ->",nl, + " {ok,",BytesAsBinary,"}",nl] + end, + " catch",nl, + " Class:Exception when Class =:= error; Class =:= exit ->",nl, + " case Exception of",nl, + " {error,Reason}=Error ->",nl, + " Error;",nl, + " Reason ->",nl, + " {error,{asn1,Reason}}",nl, + " end",nl, "end.",nl,nl]), Return_rest = lists:member(undec_rest,get(encoding_options)), @@ -999,7 +1014,7 @@ pgen_dispatcher(Erules,_Module,{Types,_Values,_,_,_Objects,_ObjectSets}) -> gen_partial_inc_dispatcher(); _PerOrPer_bin -> gen_dispatcher(Types,"encode_disp","enc_",""), - gen_dispatcher(Types,"decode_disp","dec_",",mandatory") + gen_dispatcher(Types,"decode_disp","dec_","") end, emit([nl]), emit({nl,nl}). diff --git a/lib/asn1/src/asn1ct_gen_ber_bin_v2.erl b/lib/asn1/src/asn1ct_gen_ber_bin_v2.erl index 8ab49aec2c..de81259fcb 100644 --- a/lib/asn1/src/asn1ct_gen_ber_bin_v2.erl +++ b/lib/asn1/src/asn1ct_gen_ber_bin_v2.erl @@ -196,8 +196,16 @@ gen_encode_prim(_Erules, #type{}=D, DoTag, Value) -> emit(["case ",Value," of",nl]), emit_enc_enumerated_cases(NamedNumberList,DoTag); 'REAL' -> - emit([{call,ber,encode_tags, - [DoTag,{call,real_common,ber_encode_real,[Value]}]}]); + asn1ct_name:new(realval), + asn1ct_name:new(realsize), + emit(["begin",nl, + {curr,realval}," = ", + {call,real_common,ber_encode_real,[Value]},com,nl, + {curr,realsize}," = ", + {call,erlang,byte_size,[{curr,realval}]},com,nl, + {call,ber,encode_tags, + [DoTag,{curr,realval},{curr,realsize}]},nl, + "end"]); {'BIT STRING',NamedNumberList} -> call(encode_bit_string, [{asis,BitStringConstraint},Value, @@ -637,9 +645,6 @@ gen_encode_objectfields(ClassName,[{typefield,Name,OptOrMand}|Rest], % ", Val, RestPrimFieldName) ->",nl]), MaybeConstr= case {get_object_field(Name,ObjectFields),OptOrMand} of - {false,'MANDATORY'} -> %% this case is illegal - exit({error,{asn1,{"missing mandatory field in object", - ObjName}}}); {false,'OPTIONAL'} -> EmitFuncClause("Val"), emit([" {Val,0}"]), @@ -672,9 +677,6 @@ gen_encode_objectfields(ClassName,[{objectfield,Name,_,_,OptOrMand}|Rest], % emit(["'enc_",ObjName,"'(",{asis,Name}, % ", Val,[H|T]) ->",nl]), case {get_object_field(Name,ObjectFields),OptOrMand} of - {false,'MANDATORY'} -> - exit({error,{asn1,{"missing mandatory field in object", - ObjName}}}); {false,'OPTIONAL'} -> EmitFuncClause("_,_"), emit([" exit({error,{'use of missing field in object', ",{asis,Name}, @@ -807,9 +809,6 @@ gen_decode_objectfields(ClassName,[{typefield,Name,OptOrMand}|Rest], % ", Bytes, RestPrimFieldName) ->",nl]), MaybeConstr= case {get_object_field(Name,ObjectFields),OptOrMand} of - {false,'MANDATORY'} -> %% this case is illegal - exit({error,{asn1,{"missing mandatory field in object", - ObjName}}}); {false,'OPTIONAL'} -> EmitFuncClause(" Bytes"), emit([" Bytes"]), @@ -844,9 +843,6 @@ gen_decode_objectfields(ClassName,[{objectfield,Name,_,_,OptOrMand}|Rest], % ", Bytes,[H|T]) ->",nl]), % emit_tlv_format("Bytes"), case {get_object_field(Name,ObjectFields),OptOrMand} of - {false,'MANDATORY'} -> - exit({error,{asn1,{"missing mandatory field in object", - ObjName}}}); {false,'OPTIONAL'} -> EmitFuncClause("_,_"), emit([" exit({error,{'illegal use of missing field in object', ",{asis,Name}, @@ -1072,8 +1068,7 @@ gen_objset_enc(_,_,{unique,undefined},_,_,_,_,_) -> gen_objset_enc(Erules, ObjSetName, UniqueName, [{ObjName,Val,Fields}|T], ClName, ClFields, NthObj,Acc)-> - emit(["'getenc_",ObjSetName,"'(",{asis,UniqueName},",",{asis,Val}, - ") ->",nl]), + emit(["'getenc_",ObjSetName,"'(",{asis,Val},") ->",nl]), CurrMod = get(currmod), {InternalFunc,NewNthObj}= case ObjName of @@ -1095,7 +1090,7 @@ gen_objset_enc(Erules, ObjSetName, UniqueName, %% See X.681 Annex E for the following case gen_objset_enc(_,ObjSetName,_UniqueName,['EXTENSIONMARK'],_ClName, _ClFields,_NthObj,Acc) -> - emit({"'getenc_",ObjSetName,"'(_, _) ->",nl}), + emit(["'getenc_",ObjSetName,"'(_) ->",nl]), emit({indent(3),"fun(_, Val, _RestPrimFieldName) ->",nl}), emit({indent(6),"Len = case Val of",nl,indent(9), "Bin when is_binary(Bin) -> byte_size(Bin);",nl,indent(9), @@ -1113,7 +1108,7 @@ emit_ext_fun(EncDec,ModuleName,Name) -> Name,"'(T,V,O) end"]). emit_default_getenc(ObjSetName,UniqueName) -> - emit(["'getenc_",ObjSetName,"'(",{asis,UniqueName},", ErrV) ->",nl]), + emit(["'getenc_",ObjSetName,"'(ErrV) ->",nl]), emit([indent(3),"fun(C,V,_) -> exit({'Type not compatible with table constraint',{component,C},{value,V}, {unique_name_and_value,",{asis,UniqueName},", ErrV}}) end"]). %% gen_inlined_enc_funs for each object iterates over all fields of a @@ -1240,8 +1235,7 @@ gen_objset_dec(_,_,{unique,undefined},_,_,_,_) -> ok; gen_objset_dec(Erules, ObjSName, UniqueName, [{ObjName,Val,Fields}|T], ClName, ClFields, NthObj)-> - emit(["'getdec_",ObjSName,"'(",{asis,UniqueName},",", - {asis,Val},") ->",nl]), + emit(["'getdec_",ObjSName,"'(",{asis,Val},") ->",nl]), CurrMod = get(currmod), NewNthObj= case ObjName of @@ -1262,7 +1256,7 @@ gen_objset_dec(Erules, ObjSName, UniqueName, [{ObjName,Val,Fields}|T], ClFields, NewNthObj); gen_objset_dec(_,ObjSetName,_UniqueName,['EXTENSIONMARK'],_ClName, _ClFields,_NthObj) -> - emit(["'getdec_",ObjSetName,"'(_, _) ->",nl]), + emit(["'getdec_",ObjSetName,"'(_) ->",nl]), emit([indent(2),"fun(_,Bytes, _RestPrimFieldName) ->",nl]), emit([indent(4),"case Bytes of",nl, @@ -1279,7 +1273,7 @@ gen_objset_dec(_, ObjSetName, UniqueName, [], _, _, _) -> ok. emit_default_getdec(ObjSetName,UniqueName) -> - emit(["'getdec_",ObjSetName,"'(",{asis,UniqueName},", ErrV) ->",nl]), + emit(["'getdec_",ObjSetName,"'(ErrV) ->",nl]), emit([indent(2), "fun(C,V,_) -> exit({{component,C},{value,V},{unique_name_and_value,",{asis,UniqueName},", ErrV}}) end"]). gen_inlined_dec_funs(Fields, ClFields, ObjSetName, NthObj) -> diff --git a/lib/asn1/src/asn1ct_gen_per.erl b/lib/asn1/src/asn1ct_gen_per.erl index 69d9d51bf1..8b999ddbf0 100644 --- a/lib/asn1/src/asn1ct_gen_per.erl +++ b/lib/asn1/src/asn1ct_gen_per.erl @@ -26,7 +26,7 @@ %-compile(export_all). -export([gen_dec_imm/2]). --export([gen_dec_prim/3,gen_encode_prim/3]). +-export([gen_dec_prim/3,gen_encode_prim_imm/3]). -export([gen_obj_code/3,gen_objectset_code/2]). -export([gen_decode/2, gen_decode/3]). -export([gen_encode/2, gen_encode/3]). @@ -102,832 +102,106 @@ gen_encode_prim(Erules, D) -> Value = asn1ct_gen:mk_var(asn1ct_name:curr(val)), gen_encode_prim(Erules, D, Value). -gen_encode_prim(Erules, #type{def={'ENUMERATED',{N1,N2}}}, Value) -> - NewList = [{0,X} || {X,_} <- N1] ++ ['EXT_MARK'] ++ - [{1,X} || {X,_} <- N2], - NewC = {0,length(N1)-1}, - emit(["case ",Value," of",nl]), - emit_enc_enumerated_cases(Erules, NewC, NewList, 0); -gen_encode_prim(Erules, #type{def={'ENUMERATED',NNL}}, Value) -> - NewList = [X || {X,_} <- NNL], - NewC = {0,length(NewList)-1}, - emit(["case ",Value," of",nl]), - emit_enc_enumerated_cases(Erules, NewC, NewList, 0); -gen_encode_prim(per=Erules, D, Value) -> - asn1ct_gen_per_rt2ct:gen_encode_prim(Erules, D, Value); gen_encode_prim(Erules, #type{}=D, Value) -> - Constraint = D#type.constraint, - SizeConstr = asn1ct_imm:effective_constraint(bitstring, Constraint), - Pa = case lists:keyfind('PermittedAlphabet', 1, Constraint) of - false -> no; - {_,Pa0} -> Pa0 - end, - case D#type.def of + Aligned = case Erules of + uper -> false; + per -> true + end, + Imm = gen_encode_prim_imm(Value, D, Aligned), + asn1ct_imm:enc_cg(Imm, Aligned). + +gen_encode_prim_imm(Val, #type{def=Type0,constraint=Constraint}, Aligned) -> + case simplify_type(Type0) of + k_m_string -> + Type = case Type0 of + 'GeneralizedTime' -> 'VisibleString'; + 'UTCTime' -> 'VisibleString'; + _ -> Type0 + end, + asn1ct_imm:per_enc_k_m_string(Val, Type, Constraint, Aligned); + restricted_string -> + ToBinary = {erlang,iolist_to_binary}, + asn1ct_imm:per_enc_restricted_string(Val, ToBinary, Aligned); + {'ENUMERATED',NNL} -> + asn1ct_imm:per_enc_enumerated(Val, NNL, Aligned); 'INTEGER' -> - Args = [{asis,asn1ct_imm:effective_constraint(integer,Constraint)}, - Value], - call(Erules, encode_integer, Args); - {'INTEGER',NamedNumberList} -> - Args = [{asis,asn1ct_imm:effective_constraint(integer,Constraint)}, - Value,{asis,NamedNumberList}], - call(Erules, encode_integer, Args); + asn1ct_imm:per_enc_integer(Val, Constraint, Aligned); + {'INTEGER',NNL} -> + asn1ct_imm:per_enc_integer(Val, NNL, Constraint, Aligned); 'REAL' -> - emit_enc_real(Erules, Value); - - {'BIT STRING',NamedNumberList} -> - call(Erules, encode_bit_string, - [{asis,SizeConstr},Value, - {asis,NamedNumberList}]); + ToBinary = {real_common,encode_real}, + asn1ct_imm:per_enc_restricted_string(Val, ToBinary, Aligned); + {'BIT STRING',NNL} -> + asn1ct_imm:per_enc_bit_string(Val, NNL, Constraint, Aligned); 'NULL' -> - emit("[]"); + asn1ct_imm:per_enc_null(Val, Aligned); 'OBJECT IDENTIFIER' -> - call(Erules, encode_object_identifier, [Value]); + ToBinary = {per_common,encode_oid}, + asn1ct_imm:per_enc_restricted_string(Val, ToBinary, Aligned); 'RELATIVE-OID' -> - call(Erules, encode_relative_oid, [Value]); - 'ObjectDescriptor' -> - call(Erules, encode_ObjectDescriptor, - [{asis,Constraint},Value]); + ToBinary = {per_common,encode_relative_oid}, + asn1ct_imm:per_enc_restricted_string(Val, ToBinary, Aligned); 'BOOLEAN' -> - call(Erules, encode_boolean, [Value]); + asn1ct_imm:per_enc_boolean(Val, Aligned); 'OCTET STRING' -> - case SizeConstr of - 0 -> - emit("[]"); - no -> - call(Erules, encode_octet_string, [Value]); - C -> - call(Erules, encode_octet_string, [{asis,C},Value]) - end; - 'NumericString' -> - call(Erules, encode_NumericString, [{asis,SizeConstr}, - {asis,Pa},Value]); - TString when TString == 'TeletexString'; - TString == 'T61String' -> - call(Erules, encode_TeletexString, [{asis,Constraint},Value]); - 'VideotexString' -> - call(Erules, encode_VideotexString, [{asis,Constraint},Value]); - 'UTCTime' -> - call(Erules, encode_VisibleString, [{asis,SizeConstr}, - {asis,Pa},Value]); - 'GeneralizedTime' -> - call(Erules, encode_VisibleString, [{asis,SizeConstr}, - {asis,Pa},Value]); - 'GraphicString' -> - call(Erules, encode_GraphicString, [{asis,Constraint},Value]); - 'VisibleString' -> - call(Erules, encode_VisibleString, [{asis,SizeConstr}, - {asis,Pa},Value]); - 'GeneralString' -> - call(Erules, encode_GeneralString, [{asis,Constraint},Value]); - 'PrintableString' -> - call(Erules, encode_PrintableString, [{asis,SizeConstr}, - {asis,Pa},Value]); - 'IA5String' -> - call(Erules, encode_IA5String, [{asis,SizeConstr}, - {asis,Pa},Value]); - 'BMPString' -> - call(Erules, encode_BMPString, [{asis,SizeConstr}, - {asis,Pa},Value]); - 'UniversalString' -> - call(Erules, encode_UniversalString, [{asis,SizeConstr}, - {asis,Pa},Value]); - 'UTF8String' -> - call(Erules, encode_UTF8String, [Value]); + asn1ct_imm:per_enc_octet_string(Val, Constraint, Aligned); 'ASN1_OPEN_TYPE' -> - NewValue = case Constraint of - [#'Externaltypereference'{type=Tname}] -> - asn1ct_func:need({Erules,complete,1}), - io_lib:format( - "complete(enc_~s(~s))",[Tname,Value]); - [#type{def=#'Externaltypereference'{type=Tname}}] -> - asn1ct_func:need({Erules,complete,1}), - io_lib:format( - "complete(enc_~s(~s))", - [Tname,Value]); - _ -> - io_lib:format("iolist_to_binary(~s)", - [Value]) - end, - call(Erules, encode_open_type, [NewValue]) - end. - -emit_enc_real(Erules, Real) -> - asn1ct_name:new(tmpval), - asn1ct_name:new(tmplen), - emit(["begin",nl, - "{",{curr,tmpval},com,{curr,tmplen},"} = ", - {call,real_common,encode_real,[Real]},com,nl, - "[",{call,Erules,encode_length,[{curr,tmplen}]},",", - {curr,tmpval},"]",nl, - "end"]). - -emit_enc_enumerated_cases(Erules, C, ['EXT_MARK'|T], _Count) -> - %% Reset enumeration counter. - emit_enc_enumerated_cases(Erules, C, T, 0); -emit_enc_enumerated_cases(Erules, C, [H|T], Count) -> - emit_enc_enumerated_case(Erules, C, H, Count), - emit([";",nl]), - emit_enc_enumerated_cases(Erules, C, T, Count+1); -emit_enc_enumerated_cases(_Erules, _, [], _Count) -> - emit(["EnumVal -> " - "exit({error,{asn1,{enumerated_not_in_range, EnumVal}}})",nl, - "end"]). - -emit_enc_enumerated_case(Erules, C, {0,EnumName}, Count) -> - %% ENUMERATED with extensionmark; the value lies within then extension root - Enc = enc_ext_and_val(Erules, 0, encode_constrained_number, [C,Count]), - emit(["'",EnumName,"' -> ",{asis,Enc}]); -emit_enc_enumerated_case(Erules, _C, {1,EnumName}, Count) -> - %% ENUMERATED with extensionmark; the value is higher than extension root - Enc = enc_ext_and_val(Erules, 1, encode_small_number, [Count]), - emit(["'",EnumName,"' -> ",{asis,Enc}]); -emit_enc_enumerated_case(Erules, C, EnumName, Count) -> - %% ENUMERATED without extension - EvalMod = eval_module(Erules), - emit(["'",EnumName,"' -> ", - {asis,EvalMod:encode_constrained_number(C, Count)}]). - -enc_ext_and_val(per, E, F, Args) -> - [E|apply(asn1ct_eval_per, F, Args)]; -enc_ext_and_val(uper, E, F, Args) -> - Bs = list_to_bitstring([apply(asn1ct_eval_uper, F, Args)]), - <<E:1,Bs/bitstring>>. - - -%% Object code generating for encoding and decoding -%% ------------------------------------------------ - -gen_obj_code(Erules,_Module,Obj) when is_record(Obj,typedef) -> - ObjName = Obj#typedef.name, - Def = Obj#typedef.typespec, - #'Externaltypereference'{module=Mod,type=ClassName} = - Def#'Object'.classname, - Class = asn1_db:dbget(Mod,ClassName), - {object,_,Fields} = Def#'Object'.def, - emit({nl,nl,nl,"%%================================"}), - emit({nl,"%% ",ObjName}), - emit({nl,"%%================================",nl}), - EncConstructed = - gen_encode_objectfields(Erules, ClassName,get_class_fields(Class), - ObjName,Fields,[]), - emit(nl), - gen_encode_constr_type(Erules,EncConstructed), - emit(nl), - DecConstructed = - gen_decode_objectfields(Erules, ClassName, get_class_fields(Class), - ObjName, Fields, []), - emit(nl), - gen_decode_constr_type(Erules,DecConstructed), - emit(nl). - - -gen_encode_objectfields(Erule, ClassName, - [{typefield,Name,OptOrMand}|Rest], - ObjName, ObjectFields, ConstrAcc) -> - EmitFuncClause = - fun(V) -> - emit(["'enc_",ObjName,"'(",{asis,Name}, - ",",V,",_RestPrimFieldName) ->",nl]) - end, -% emit(["'enc_",ObjName,"'(",{asis,Name}, -% ", Val, _RestPrimFieldName) ->",nl]), - MaybeConstr = - case {get_object_field(Name,ObjectFields),OptOrMand} of - {false,'MANDATORY'} -> %% this case is illegal - exit({error,{asn1,{"missing mandatory field in object", - ObjName}}}); - {false,'OPTIONAL'} -> - EmitFuncClause("Val"), - case Erule of - uper -> - emit(" Val"); - per -> - emit([" if",nl, - " is_list(Val) ->",nl, - " NewVal = list_to_binary(Val),",nl, - " [20,byte_size(NewVal),NewVal];",nl, - " is_binary(Val) ->",nl, - " [20,byte_size(Val),Val]",nl, - " end"]) - end, - []; - {false,{'DEFAULT',DefaultType}} -> - EmitFuncClause("Val"), - gen_encode_default_call(Erule, ClassName, Name, DefaultType); - {{Name,TypeSpec},_} -> - %% A specified field owerwrites any 'DEFAULT' or - %% 'OPTIONAL' field in the class - EmitFuncClause("Val"), - gen_encode_field_call(Erule, ObjName, Name, TypeSpec) - end, - case more_genfields(Rest) of - true -> - emit([";",nl]); - false -> - emit([".",nl]) - end, - gen_encode_objectfields(Erule,ClassName,Rest,ObjName,ObjectFields, - MaybeConstr++ConstrAcc); -gen_encode_objectfields(Erule,ClassName,[{objectfield,Name,_,_,OptOrMand}|Rest], - ObjName,ObjectFields,ConstrAcc) -> - CurrentMod = get(currmod), - EmitFuncClause = - fun(Attrs) -> - emit(["'enc_",ObjName,"'(",{asis,Name}, - ",",Attrs,") ->",nl]) - end, -% emit(["'enc_",ObjName,"'(",{asis,Name}, -% ", Val,[H|T]) ->",nl]), - case {get_object_field(Name,ObjectFields),OptOrMand} of - {false,'MANDATORY'} -> - exit({error,{asn1,{"missing mandatory field in object", - ObjName}}}); - {false,'OPTIONAL'} -> - EmitFuncClause("_,_"), - emit([" exit({error,{'use of missing field in object', ",{asis,Name}, - "}})"]); - {false,{'DEFAULT',_DefaultObject}} -> - exit({error,{asn1,{"not implemented yet",Name}}}); - {{Name,#'Externalvaluereference'{module=CurrentMod, - value=TypeName}},_} -> - EmitFuncClause(" Val, [H|T]"), - emit({indent(3),"'enc_",TypeName,"'(H, Val, T)"}); - {{Name,#'Externalvaluereference'{module=M,value=TypeName}},_} -> - EmitFuncClause(" Val, [H|T]"), - emit({indent(3),"'",M,"':'enc_",TypeName,"'(H, Val, T)"}); - {{Name,TypeSpec},_} -> - EmitFuncClause("Val,[H|T]"), - case TypeSpec#typedef.name of - {ExtMod,TypeName} -> - emit({indent(3),"'",ExtMod,"':'enc_",TypeName, - "'(H, Val, T)"}); - TypeName -> - emit({indent(3),"'enc_",TypeName,"'(H, Val, T)"}) + case Constraint of + [#'Externaltypereference'{type=Tname}] -> + EncFunc = enc_func(Tname), + Imm = [{apply,EncFunc,[{expr,Val}]}], + asn1ct_imm:per_enc_open_type(Imm, Aligned); + [] -> + Imm = [{call,erlang,iolist_to_binary,[{expr,Val}]}], + asn1ct_imm:per_enc_open_type(Imm, Aligned) end - end, - case more_genfields(Rest) of - true -> - emit([";",nl]); - false -> - emit([".",nl]) - end, - gen_encode_objectfields(Erule,ClassName,Rest,ObjName,ObjectFields,ConstrAcc); -gen_encode_objectfields(Erule,ClassName,[_C|Cs],O,OF,Acc) -> - gen_encode_objectfields(Erule,ClassName,Cs,O,OF,Acc); -gen_encode_objectfields(_, _,[],_,_,Acc) -> - Acc. - - -gen_encode_constr_type(Erules,[TypeDef|Rest]) when is_record(TypeDef,typedef) -> - case is_already_generated(enc,TypeDef#typedef.name) of - true -> ok; - _ -> -%% FuncName = list_to_atom(lists:concat(["enc_",TypeDef#typedef.name])), - FuncName = asn1ct_gen:list2rname(TypeDef#typedef.name ++ [enc]), - emit(["'",FuncName,"'(Val) ->",nl]), - Def = TypeDef#typedef.typespec, - InnerType = asn1ct_gen:get_inner(Def#type.def), - asn1ct_gen:gen_encode_constructed(Erules,TypeDef#typedef.name, - InnerType,Def), - gen_encode_constr_type(Erules,Rest) - end; -gen_encode_constr_type(_,[]) -> - ok. - -gen_encode_field_call(_Erules, _ObjName, _FieldName, - #'Externaltypereference'{module=M,type=T}) -> - CurrentMod = get(currmod), - if - M == CurrentMod -> - emit({" 'enc_",T,"'(Val)"}), - []; - true -> - emit({" '",M,"':'enc_",T,"'(Val)"}), - [] - end; -gen_encode_field_call(Erules, ObjName, FieldName, Type) -> - Def = Type#typedef.typespec, - case Type#typedef.name of - {primitive,bif} -> - gen_encode_prim(Erules, Def, "Val"), - []; - {constructed,bif} -> - emit({" 'enc_",ObjName,'_',FieldName, - "'(Val)"}), -%% [Type#typedef{name=list_to_atom(lists:concat([ObjName,'_',FieldName]))}]; - [Type#typedef{name=[FieldName,ObjName]}]; - {ExtMod,TypeName} -> - emit({" '",ExtMod,"':'enc_",TypeName, - "'(Val)"}), - []; - TypeName -> - emit({" 'enc_",TypeName,"'(Val)"}), - [] end. -gen_encode_default_call(Erules, ClassName, FieldName, Type) -> - CurrentMod = get(currmod), - InnerType = asn1ct_gen:get_inner(Type#type.def), - case asn1ct_gen:type(InnerType) of - {constructed,bif} -> -%% asn1ct_gen:gen_encode_constructed(Erules,Typename,InnerType,Type); - emit([" 'enc_",ClassName,'_',FieldName,"'(Val)"]), -%% [#typedef{name=list_to_atom(lists:concat([ClassName,'_',FieldName])), - [#typedef{name=[FieldName,ClassName], - typespec=Type}]; - {primitive,bif} -> - gen_encode_prim(Erules, Type, "Val"), - []; - #'Externaltypereference'{module=CurrentMod,type=Etype} -> - emit([" 'enc_",Etype,"'(Val)",nl]), - []; - #'Externaltypereference'{module=Emod,type=Etype} -> - emit([" '",Emod,"':'enc_",Etype,"'(Val)",nl]), - [] - end. - - -gen_decode_objectfields(Erules, ClassName, - [{typefield,Name,OptOrMand}|Rest], - ObjName, ObjectFields, ConstrAcc) -> - EmitFuncClause = - fun(Bytes) -> - emit(["'dec_",ObjName,"'(",{asis,Name},",",Bytes, - ",_,_RestPrimFieldName) ->",nl]) - end, - MaybeConstr= - case {get_object_field(Name,ObjectFields),OptOrMand} of - {false,'MANDATORY'} -> %% this case is illegal - exit({error,{asn1,{"missing mandatory field in object", - ObjName}}}); - {false,'OPTIONAL'} -> - EmitFuncClause("Bytes"), - emit([" {Bytes,[]}"]), - []; - {false,{'DEFAULT',DefaultType}} -> - EmitFuncClause("Bytes"), - gen_decode_default_call(Erules, ClassName, Name, "Bytes", - DefaultType); - {{Name,TypeSpec},_} -> - %% A specified field owerwrites any 'DEFAULT' or - %% 'OPTIONAL' field in the class - EmitFuncClause("Bytes"), - gen_decode_field_call(Erules, ObjName, Name, "Bytes", TypeSpec) - end, - case more_genfields(Rest) of - true -> - emit([";",nl]); - false -> - emit([".",nl]) - end, - gen_decode_objectfields(Erules, ClassName, Rest, ObjName, - ObjectFields, MaybeConstr++ConstrAcc); -gen_decode_objectfields(Erules, ClassName, - [{objectfield,Name,_,_,OptOrMand}|Rest], - ObjName, ObjectFields, ConstrAcc) -> - CurrentMod = get(currmod), - EmitFuncClause = - fun(Attrs) -> - emit(["'dec_",ObjName,"'(",{asis,Name}, - ",",Attrs,") ->",nl]) - end, -% emit(["'dec_",ObjName,"'(",{asis,Name}, -% ", Bytes,_,[H|T]) ->",nl]), - case {get_object_field(Name,ObjectFields),OptOrMand} of - {false,'MANDATORY'} -> - exit({error,{asn1,{"missing mandatory field in object", - ObjName}}}); - {false,'OPTIONAL'} -> - EmitFuncClause("_,_,_"), - emit([" exit({error,{'illegal use of missing field in object', ",{asis,Name}, - "}})"]); - {false,{'DEFAULT',_DefaultObject}} -> - exit({error,{asn1,{"not implemented yet",Name}}}); - {{Name,#'Externalvaluereference'{module=CurrentMod, - value=TypeName}},_} -> - EmitFuncClause("Bytes,_,[H|T]"), - emit({indent(3),"'dec_",TypeName,"'(H, Bytes, telltype, T)"}); - {{Name,#'Externalvaluereference'{module=M,value=TypeName}},_} -> - EmitFuncClause("Bytes,_,[H|T]"), - emit({indent(3),"'",M,"':'dec_",TypeName, - "'(H, Bytes, telltype, T)"}); - {{Name,TypeSpec},_} -> - EmitFuncClause("Bytes,_,[H|T]"), - case TypeSpec#typedef.name of - {ExtMod,TypeName} -> - emit({indent(3),"'",ExtMod,"':'dec_",TypeName, - "'(H, Bytes, telltype, T)"}); - TypeName -> - emit({indent(3),"'dec_",TypeName,"'(H, Bytes, telltype, T)"}) - end - end, - case more_genfields(Rest) of - true -> - emit([";",nl]); - false -> - emit([".",nl]) - end, - gen_decode_objectfields(Erules, ClassName, Rest, ObjName, - ObjectFields, ConstrAcc); -gen_decode_objectfields(Erules, CN, [_C|Cs], O, OF, CAcc) -> - gen_decode_objectfields(Erules, CN, Cs, O, OF, CAcc); -gen_decode_objectfields(_, _, [], _, _, CAcc) -> - CAcc. - - - -gen_decode_field_call(_Erules, _ObjName, _FieldName, Bytes, - #'Externaltypereference'{}=Etype) -> - emit(" "), - gen_dec_external(Etype, Bytes), - []; -gen_decode_field_call(Erules, ObjName, FieldName, Bytes, Type) -> - Def = Type#typedef.typespec, - case Type#typedef.name of - {primitive,bif} -> - gen_dec_prim(Erules, Def, Bytes), - []; - {constructed,bif} -> - emit({" 'dec_",ObjName,'_',FieldName, - "'(",Bytes,",telltype)"}), -%% [Type#typedef{name=list_to_atom(lists:concat([ObjName,'_',FieldName]))}]; - [Type#typedef{name=[FieldName,ObjName]}]; - {ExtMod,TypeName} -> - emit({" '",ExtMod,"':'dec_",TypeName, - "'(",Bytes,", telltype)"}), - []; - TypeName -> - emit({" 'dec_",TypeName,"'(",Bytes,", telltype)"}), - [] - end. - -gen_decode_default_call(Erules, ClassName, FieldName, Bytes, Type) -> - InnerType = asn1ct_gen:get_inner(Type#type.def), - case asn1ct_gen:type(InnerType) of - {constructed,bif} -> - emit([" 'dec_",ClassName,'_',FieldName,"'(",Bytes,", telltype)"]), -%% [#typedef{name=list_to_atom(lists:concat([ClassName,'_',FieldName])), - [#typedef{name=[FieldName,ClassName], - typespec=Type}]; - {primitive,bif} -> - gen_dec_prim(Erules, Type, Bytes), - []; - #'Externaltypereference'{}=Etype -> - asn1ct_gen_per:gen_dec_external(Etype, Bytes), - [] +dec_func(Tname) -> + list_to_atom(lists:concat(["dec_",Tname])). + +enc_func(Tname) -> + list_to_atom(lists:concat(["enc_",Tname])). + +simplify_type(Type) -> + case Type of + 'BMPString' -> k_m_string; + 'IA5String' -> k_m_string; + 'NumericString' -> k_m_string; + 'PrintableString' -> k_m_string; + 'VisibleString' -> k_m_string; + 'UniversalString' -> k_m_string; + 'GeneralizedTime' -> k_m_string; + 'UTCTime' -> k_m_string; + 'TeletexString' -> restricted_string; + 'T61String' -> restricted_string; + 'VideotexString' -> restricted_string; + 'GraphicString' -> restricted_string; + 'GeneralString' -> restricted_string; + 'UTF8String' -> restricted_string; + 'ObjectDescriptor' -> restricted_string; + Other -> Other end. +%% Object code generating for encoding and decoding +%% ------------------------------------------------ -gen_decode_constr_type(Erules,[TypeDef|Rest]) when is_record(TypeDef,typedef) -> - case is_already_generated(dec,TypeDef#typedef.name) of - true -> ok; - _ -> - gen_decode(Erules,TypeDef#typedef{name=asn1ct_gen:list2rname(TypeDef#typedef.name)}) - end, - gen_decode_constr_type(Erules,Rest); -gen_decode_constr_type(_,[]) -> +gen_obj_code(_Erules, _Module, #typedef{}) -> ok. - -more_genfields([]) -> - false; -more_genfields([Field|Fields]) -> - case element(1,Field) of - typefield -> - true; - objectfield -> - true; - _ -> - more_genfields(Fields) - end. - %% Object Set code generating for encoding and decoding %% ---------------------------------------------------- -gen_objectset_code(Erules,ObjSet) -> - ObjSetName = ObjSet#typedef.name, - Def = ObjSet#typedef.typespec, -%% {ClassName,ClassDef} = Def#'ObjectSet'.class, - #'Externaltypereference'{module=ClassModule, - type=ClassName} = Def#'ObjectSet'.class, - ClassDef = asn1_db:dbget(ClassModule,ClassName), - UniqueFName = Def#'ObjectSet'.uniquefname, - Set = Def#'ObjectSet'.set, - emit({nl,nl,nl,"%%================================"}), - emit({nl,"%% ",ObjSetName}), - emit({nl,"%%================================",nl}), - case ClassName of - {_Module,ExtClassName} -> - gen_objset_code(Erules,ObjSetName,UniqueFName,Set, - ExtClassName,ClassDef); - _ -> - gen_objset_code(Erules,ObjSetName,UniqueFName,Set, - ClassName,ClassDef) - end, - emit(nl). - -gen_objset_code(Erules,ObjSetName,UniqueFName,Set,ClassName,ClassDef)-> - ClassFields = (ClassDef#classdef.typespec)#objectclass.fields, - InternalFuncs= - gen_objset_enc(Erules,ObjSetName,UniqueFName,Set,ClassName,ClassFields,1,[]), - gen_objset_dec(Erules, ObjSetName,UniqueFName,Set,ClassName,ClassFields,1), - gen_internal_funcs(Erules,InternalFuncs). - -%% gen_objset_enc iterates over the objects of the object set -gen_objset_enc(_,_,{unique,undefined},_,_,_,_,_) -> - %% There is no unique field in the class of this object set - %% don't bother about the constraint - []; -gen_objset_enc(Erule, ObjSetName, UniqueName, [{ObjName,Val,Fields}|T], - ClName, ClFields, NthObj, Acc)-> - emit(["'getenc_",ObjSetName,"'(",{asis,UniqueName},",",{asis,Val}, - ") ->",nl]), - CurrMod = get(currmod), - {InternalFunc,NewNthObj}= - case ObjName of - {no_mod,no_name} -> - gen_inlined_enc_funs(Erule, Fields, ClFields, - ObjSetName, NthObj); - {CurrMod,Name} -> - emit({" fun 'enc_",Name,"'/3"}), - {[],0}; - {ModName,Name} -> - emit_ext_encfun(ModName,Name), - {[],0}; - _Other -> - emit({" fun 'enc_",ObjName,"'/3"}), - {[],0} - end, - emit({";",nl}), - gen_objset_enc(Erule, ObjSetName, UniqueName, T, ClName, ClFields, - NewNthObj, InternalFunc ++ Acc); -gen_objset_enc(uper, ObjSetName, _UniqueName, ['EXTENSIONMARK'], - _ClName, _ClFields, _NthObj, Acc) -> - emit({"'getenc_",ObjSetName,"'(_, _) ->",nl}), - emit({indent(3),"fun(_, Val, _) ->",nl}), - emit([indent(6),"Val",nl, - indent(3),"end.",nl,nl]), - Acc; -gen_objset_enc(per, ObjSetName, _UniqueName, ['EXTENSIONMARK'], - _ClName, _ClFields, _NthObj, Acc) -> - emit(["'getenc_",ObjSetName,"'(_, _) ->",nl, - indent(3),"fun(_, Val, _) ->",nl, - indent(6),"BinVal = if",nl, - indent(9),"is_list(Val) -> list_to_binary(Val);",nl, - indent(9),"true -> Val",nl, - indent(6),"end,",nl, - indent(6),"Size = byte_size(BinVal),",nl, - indent(6),"if",nl, - indent(9),"Size < 256 ->",nl, - indent(12),"[20,Size,BinVal];",nl, - indent(9),"true ->",nl, - indent(12),"[21,<<Size:16>>,Val]",nl, - indent(6),"end",nl, - indent(3),"end.",nl,nl]), - Acc; -gen_objset_enc(_, ObjSetName, UniqueName, [], _, _, _, Acc) -> - emit_default_getenc(ObjSetName, UniqueName), - emit([".",nl,nl]), - Acc. - -emit_ext_encfun(ModuleName,Name) -> - emit([indent(4),"fun(T,V,O) -> '",ModuleName,"':'enc_", - Name,"'(T,V,O) end"]). - -emit_default_getenc(ObjSetName,UniqueName) -> - emit(["'getenc_",ObjSetName,"'(",{asis,UniqueName},", ErrV) ->",nl]), - emit([indent(4),"fun(C,V,_) -> exit({'Type not compatible with table constraint',{component,C},{value,V},{unique_name_and_value,",{asis,UniqueName},",ErrV}}) end"]). - - -%% gen_inlined_enc_funs for each object iterates over all fields of a -%% class, and for each typefield it checks if the object has that -%% field and emits the proper code. -gen_inlined_enc_funs(Erule, Fields, [{typefield,_,_}|_]=T, - ObjSetName, NthObj) -> - emit([indent(3),"fun(Type, Val, _) ->",nl, - indent(6),"case Type of",nl]), - gen_inlined_enc_funs1(Erule, Fields, T, ObjSetName, [], NthObj, []); -gen_inlined_enc_funs(Erule,Fields,[_H|Rest],ObjSetName,NthObj) -> - gen_inlined_enc_funs(Erule,Fields,Rest,ObjSetName,NthObj); -gen_inlined_enc_funs(_,_,[],_,NthObj) -> - {[],NthObj}. - -gen_inlined_enc_funs1(Erule, Fields, [{typefield,Name,_}|Rest], ObjSetName, - Sep0, NthObj, Acc0) -> - emit(Sep0), - Sep = [";",nl], - CurrentMod = get(currmod), - InternalDefFunName = asn1ct_gen:list2name([NthObj,Name,ObjSetName]), - {Acc,NAdd} = - case lists:keyfind(Name, 1, Fields) of - {_,#type{}=Type} -> - {Ret,N} = emit_inner_of_fun(Erule, Type, InternalDefFunName), - {Ret++Acc0,N}; - {_,#typedef{}=Type} -> - emit([indent(9),{asis,Name}," ->",nl]), - {Ret,N} = emit_inner_of_fun(Erule, Type, InternalDefFunName), - {Ret++Acc0,N}; - {_,#'Externaltypereference'{module=CurrentMod,type=T}} -> - emit([indent(9),{asis,Name}," ->",nl, - indent(12),"'enc_",T,"'(Val)"]), - {Acc0,0}; - {_,#'Externaltypereference'{module=M,type=T}} -> - emit([indent(9),{asis,Name}," ->",nl, - indent(12),"'",M,"'",":'enc_",T,"'(Val)"]), - {Acc0,0}; - false when Erule =:= uper -> - emit([indent(9),{asis,Name}," ->",nl, - indent(12),"Val",nl]), - {Acc0,0}; - false when Erule =:= per -> - emit([indent(9),{asis,Name}," ->",nl, - indent(12),"Size = case Val of",nl, - indent(15),"B when is_binary(B) -> size(B);",nl, - indent(15),"_ -> length(Val)",nl, - indent(12),"end,",nl, - indent(12),"if",nl, - indent(15),"Size < 256 -> [20,Size,Val];",nl, - indent(15),"true -> [21,<<Size:16>>,Val]",nl, - indent(12),"end"]), - {Acc0,0} - end, - gen_inlined_enc_funs1(Erule, Fields, Rest, ObjSetName, Sep, - NthObj+NAdd, Acc); -gen_inlined_enc_funs1(Erule, Fields, [_|T], ObjSetName, Sep, NthObj, Acc)-> - gen_inlined_enc_funs1(Erule, Fields, T, ObjSetName, Sep, NthObj, Acc); -gen_inlined_enc_funs1(_, _, [], _, _, NthObj, Acc) -> - emit([nl,indent(6),"end",nl, - indent(3),"end"]), - {Acc,NthObj}. - -emit_inner_of_fun(Erule, #typedef{name={ExtMod,Name},typespec=Type}=TDef, - InternalDefFunName) -> - case {ExtMod,Name} of - {primitive,bif} -> - emit(indent(12)), - gen_encode_prim(Erule, Type, "Val"), - {[],0}; - {constructed,bif} -> - emit([indent(12),"'enc_", - InternalDefFunName,"'(Val)"]), - {[TDef#typedef{name=InternalDefFunName}],1}; - _ -> - emit({indent(12),"'",ExtMod,"':'enc_",Name,"'(Val)"}), - {[],0} - end; -emit_inner_of_fun(_Erule, #typedef{name=Name}, _) -> - emit({indent(12),"'enc_",Name,"'(Val)"}), - {[],0}; -emit_inner_of_fun(Erule, #type{}=Type, _) -> - CurrMod = get(currmod), - case Type#type.def of - Def when is_atom(Def) -> - emit({indent(9),Def," ->",nl,indent(12)}), - gen_encode_prim(Erule, Type, "Val"); - #'Externaltypereference'{module=CurrMod,type=T} -> - emit({indent(9),T," ->",nl,indent(12),"'enc_",T,"'(Val)"}); - #'Externaltypereference'{module=ExtMod,type=T} -> - emit({indent(9),T," ->",nl,indent(12),ExtMod,":'enc_", - T,"'(Val)"}) - end, - {[],0}. - -indent(N) -> - lists:duplicate(N,32). % 32 = space - - -gen_objset_dec(_, _, {unique,undefined}, _, _, _, _) -> - %% There is no unique field in the class of this object set - %% don't bother about the constraint - ok; -gen_objset_dec(Erule, ObjSName, UniqueName, [{ObjName,Val,Fields}|T], ClName, - ClFields, NthObj)-> - emit({"'getdec_",ObjSName,"'(",{asis,UniqueName},",",{asis,Val}, - ") ->",nl}), - CurrMod = get(currmod), - NewNthObj= - case ObjName of - {no_mod,no_name} -> - gen_inlined_dec_funs(Erule, Fields, ClFields, - ObjSName, NthObj); - {CurrMod,Name} -> - emit([" fun 'dec_",Name,"'/4"]), - NthObj; - {ModName,Name} -> - emit_ext_decfun(ModName,Name), - NthObj; - _Other -> - emit({" fun 'dec_",ObjName,"'/4"}), - NthObj - end, - emit({";",nl}), - gen_objset_dec(Erule, ObjSName, UniqueName, T, ClName, ClFields, NewNthObj); -gen_objset_dec(_Erule, ObjSetName, _UniqueName, ['EXTENSIONMARK'], - _ClName, _ClFields, _NthObj) -> - emit({"'getdec_",ObjSetName,"'(_, _) ->",nl}), - emit({indent(3),"fun(Attr1, Bytes, _,_) ->",nl}), - emit({indent(6),"{Bytes,Attr1}",nl}), - emit({indent(3),"end.",nl,nl}), - ok; -gen_objset_dec(_Erule, ObjSetName, UniqueName, [], _, _, _) -> - emit_default_getdec(ObjSetName, UniqueName), - emit([".",nl,nl]), +gen_objectset_code(_Erules, _ObjSet) -> ok. -emit_ext_decfun(ModuleName,Name) -> - emit([indent(3),"fun(T,V,O1,O2) -> '",ModuleName,"':'dec_", - Name,"'(T,V,O1,O2) end"]). - -emit_default_getdec(ObjSetName,UniqueName) -> - emit(["'getdec_",ObjSetName,"'(",{asis,UniqueName},", ErrV) ->",nl]), - emit([indent(2), "fun(C,V,_,_) -> exit({{component,C},{value,V},{unique_name_and_value,",{asis,UniqueName},",ErrV}}) end"]). - - -gen_inlined_dec_funs(Erule, Fields, List, ObjSetName, NthObj0) -> - emit([indent(3),"fun(Type, Val, _, _) ->",nl, - indent(6),"case Type of",nl]), - NthObj = gen_inlined_dec_funs1(Erule, Fields, List, - ObjSetName, "", NthObj0), - emit([nl,indent(6),"end",nl, - indent(3),"end"]), - NthObj. - -gen_inlined_dec_funs1(Erule, Fields, [{typefield,Name,_}|Rest], - ObjSetName, Sep0, NthObj) -> - InternalDefFunName = [NthObj,Name,ObjSetName], - emit(Sep0), - Sep = [";",nl], - N = case lists:keyfind(Name, 1, Fields) of - {_,#type{}=Type} -> - emit_inner_of_decfun(Erule, Type, InternalDefFunName); - {_,#typedef{}=Type} -> - emit([indent(9),{asis,Name}," ->",nl]), - emit_inner_of_decfun(Erule, Type, InternalDefFunName); - {_,#'Externaltypereference'{}=Etype} -> - emit([indent(9),{asis,Name}," ->",nl, - indent(12)]), - gen_dec_external(Etype, "Val"), - 0; - false -> - emit([indent(9),{asis,Name}," -> {Val,Type}"]), - 0 - end, - gen_inlined_dec_funs1(Erule, Fields, Rest, ObjSetName, Sep, NthObj+N); -gen_inlined_dec_funs1(Erule, Fields, [_|Rest], ObjSetName, Sep, NthObj) -> - gen_inlined_dec_funs1(Erule, Fields, Rest, ObjSetName, Sep, NthObj); -gen_inlined_dec_funs1(_, _, [], _, _, NthObj) -> NthObj. - -emit_inner_of_decfun(Erule, #typedef{name={ExtName,Name},typespec=Type}, - InternalDefFunName) -> - case {ExtName,Name} of - {primitive,bif} -> - emit(indent(12)), - gen_dec_prim(Erule, Type, "Val"), - 0; - {constructed,bif} -> - emit({indent(12),"'dec_", - asn1ct_gen:list2name(InternalDefFunName),"'(Val)"}), - 1; - _ -> - emit({indent(12),"'",ExtName,"':'dec_",Name,"'(Val, telltype)"}), - 0 - end; -emit_inner_of_decfun(_Erule, #typedef{name=Name}, _) -> - emit({indent(12),"'dec_",Name,"'(Val, telltype)"}), - 0; -emit_inner_of_decfun(Erule, #type{}=Type, _) -> - CurrMod = get(currmod), - case Type#type.def of - Def when is_atom(Def) -> - emit({indent(9),Def," ->",nl,indent(12)}), - gen_dec_prim(Erule, Type, "Val"); - #'Externaltypereference'{module=CurrMod,type=T} -> - emit({indent(9),T," ->",nl,indent(12),"'dec_",T,"'(Val)"}); - #'Externaltypereference'{module=ExtMod,type=T} -> - emit({indent(9),T," ->",nl,indent(12),ExtMod,":'dec_", - T,"'(Val)"}) - end, - 0. - - -gen_internal_funcs(_,[]) -> - ok; -gen_internal_funcs(Erules,[TypeDef|Rest]) -> - gen_encode_user(Erules,TypeDef), - emit([nl,nl,"'dec_",TypeDef#typedef.name,"'(Bytes) ->",nl]), - gen_decode_user(Erules,TypeDef), - gen_internal_funcs(Erules,Rest). - - - %% DECODING ***************************** %%*************************************** -gen_decode(Erules,Type) when is_record(Type,typedef) -> - D = Type, - emit({nl,nl}), - emit({"'dec_",Type#typedef.name,"'(Bytes,_) ->",nl}), +gen_decode(Erules, #typedef{}=Type) -> + DecFunc = dec_func(Type#typedef.name), + emit([nl,nl,{asis,DecFunc},"(Bytes) ->",nl]), dbdec(Type#typedef.name), - gen_decode_user(Erules,D). + gen_decode_user(Erules, Type). gen_decode(Erules,Tname,#'ComponentType'{name=Cname,typespec=Type}) -> NewTname = [Cname|Tname], @@ -944,8 +218,9 @@ gen_decode(Erules,Typename,Type) when is_record(Type,type) -> _ -> "" end, - emit({nl,"'dec_",asn1ct_gen:list2name(Typename), - "'(Bytes,_",ObjFun,") ->",nl}), + emit([nl, + {asis,dec_func(asn1ct_gen:list2name(Typename))}, + "(Bytes",ObjFun,") ->",nl]), dbdec(Typename), asn1ct_gen:gen_decode_constructed(Erules,Typename,InnerType,Type); _ -> @@ -982,8 +257,8 @@ gen_dec_external(Ext, BytesVar) -> #'Externaltypereference'{module=Mod,type=Type} = Ext, emit([case CurrMod of Mod -> []; - _ -> ["'",Mod,"':"] - end,"'dec_",Type,"'(",BytesVar,",telltype)"]). + _ -> [{asis,Mod},":"] + end,{asis,dec_func(Type)},"(",BytesVar,")"]). gen_dec_imm(Erule, #type{def=Name,constraint=C}) -> Aligned = case Erule of @@ -1103,35 +378,6 @@ gen_dec_prim(Erule, Type, BytesVar) -> Imm = gen_dec_imm(Erule, Type), asn1ct_imm:dec_code_gen(Imm, BytesVar). -is_already_generated(Operation,Name) -> - case get(class_default_type) of - undefined -> - put(class_default_type,[{Operation,Name}]), - false; - GeneratedList -> - case lists:member({Operation,Name},GeneratedList) of - true -> - true; - false -> - put(class_default_type,[{Operation,Name}|GeneratedList]), - false - end - end. - -get_class_fields(#classdef{typespec=ObjClass}) -> - ObjClass#objectclass.fields; -get_class_fields(#objectclass{fields=Fields}) -> - Fields; -get_class_fields(_) -> - []. - - -get_object_field(Name,ObjectFields) -> - case lists:keysearch(Name,1,ObjectFields) of - {value,Field} -> Field; - false -> false - end. - %% For PER the ExtensionAdditionGroup notation has significance for the encoding and decoding %% the components within the ExtensionAdditionGroup is treated in a similar way as if they @@ -1170,11 +416,8 @@ imm_dec_open_type_1(Type, Aligned) -> asn1ct_name:new(tmpval), emit(["begin",nl, "{",{curr,tmpval},",_} = ", - "dec_",Type,"(",OpenType,", mandatory),",nl, + {asis,dec_func(Type)},"(",OpenType,"),",nl, "{",{curr,tmpval},com,Buf,"}",nl, "end"]) end, {call,D,asn1ct_imm:per_dec_open_type(Aligned)}. - -eval_module(per) -> asn1ct_eval_per; -eval_module(uper) -> asn1ct_eval_uper. diff --git a/lib/asn1/src/asn1ct_gen_per_rt2ct.erl b/lib/asn1/src/asn1ct_gen_per_rt2ct.erl deleted file mode 100644 index 012d54e7a1..0000000000 --- a/lib/asn1/src/asn1ct_gen_per_rt2ct.erl +++ /dev/null @@ -1,461 +0,0 @@ -%% -%% %CopyrightBegin% -%% -%% Copyright Ericsson AB 2002-2013. 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 -%% compliance with the License. You should have received a copy of the -%% Erlang Public License along with this software. If not, it can be -%% retrieved online at http://www.erlang.org/. -%% -%% Software distributed under the License is distributed on an "AS IS" -%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See -%% the License for the specific language governing rights and limitations -%% under the License. -%% -%% %CopyrightEnd% -%% -%% --module(asn1ct_gen_per_rt2ct). - -%% Handle encoding of primitives for aligned PER. - --include("asn1_records.hrl"). - --export([gen_encode_prim/3]). - --import(asn1ct_gen, [emit/1,demit/1]). --import(asn1ct_func, [call/3]). - -gen_encode_prim(Erules, #type{}=D, Value) -> - Constraint = D#type.constraint, - case D#type.def of - 'INTEGER' -> - EffectiveConstr = effective_constraint(integer,Constraint), - emit([" %%INTEGER with effective constraint: ", - {asis,EffectiveConstr},nl]), - emit_enc_integer(Erules,EffectiveConstr,Value); - {'INTEGER',NamedNumberList} -> - EffectiveConstr = effective_constraint(integer,Constraint), - %% maybe an emit_enc_NNL_integer - emit([" %%INTEGER with effective constraint: ", - {asis,EffectiveConstr},nl]), - emit_enc_integer_NNL(Erules,EffectiveConstr,Value,NamedNumberList); - 'REAL' -> - emit_enc_real(Erules, Value); - - {'BIT STRING',NamedNumberList} -> - EffectiveC = effective_constraint(bitstring,Constraint), - case EffectiveC of - 0 -> - emit({"[]"}); - _ -> - call(Erules, encode_bit_string, - [{asis,EffectiveC},Value, - {asis,NamedNumberList}]) - end; - 'NULL' -> - emit("[]"); - 'OBJECT IDENTIFIER' -> - call(Erules, encode_object_identifier, [Value]); - 'RELATIVE-OID' -> - call(Erules, encode_relative_oid, [Value]); - 'ObjectDescriptor' -> - call(Erules, encode_ObjectDescriptor, - [{asis,Constraint},Value]); - 'BOOLEAN' -> - emit({"case ",Value," of",nl, - " true -> [1];",nl, - " false -> [0];",nl, - " _ -> exit({error,{asn1,{encode_boolean,",Value,"}}})",nl, - "end"}); - 'OCTET STRING' -> - emit_enc_octet_string(Erules,Constraint,Value); - - 'NumericString' -> - emit_enc_known_multiplier_string('NumericString',Constraint,Value); - TString when TString == 'TeletexString'; - TString == 'T61String' -> - call(Erules, encode_TeletexString, [{asis,Constraint},Value]); - 'VideotexString' -> - call(Erules, encode_VideotexString, [{asis,Constraint},Value]); - 'UTCTime' -> - emit_enc_known_multiplier_string('VisibleString',Constraint,Value); - 'GeneralizedTime' -> - emit_enc_known_multiplier_string('VisibleString',Constraint,Value); - 'GraphicString' -> - call(Erules, encode_GraphicString, [{asis,Constraint},Value]); - 'VisibleString' -> - emit_enc_known_multiplier_string('VisibleString',Constraint,Value); - 'GeneralString' -> - call(Erules, encode_GeneralString, [{asis,Constraint},Value]); - 'PrintableString' -> - emit_enc_known_multiplier_string('PrintableString',Constraint,Value); - 'IA5String' -> - emit_enc_known_multiplier_string('IA5String',Constraint,Value); - 'BMPString' -> - emit_enc_known_multiplier_string('BMPString',Constraint,Value); - 'UniversalString' -> - emit_enc_known_multiplier_string('UniversalString',Constraint,Value); - 'UTF8String' -> - call(Erules, encode_UTF8String, [Value]); - 'ASN1_OPEN_TYPE' -> - NewValue = case Constraint of - [#'Externaltypereference'{type=Tname}] -> - asn1ct_func:need({Erules,complete,1}), - io_lib:format( - "complete(enc_~s(~s))",[Tname,Value]); - [#type{def=#'Externaltypereference'{type=Tname}}] -> - asn1ct_func:need({Erules,complete,1}), - io_lib:format( - "complete(enc_~s(~s))", - [Tname,Value]); - _ -> - io_lib:format("iolist_to_binary(~s)", - [Value]) - end, - call(Erules, encode_open_type, [NewValue]) - end. - -emit_enc_real(Erules, Real) -> - asn1ct_name:new(tmpval), - asn1ct_name:new(tmplen), - emit(["begin",nl, - "{",{curr,tmpval},com,{curr,tmplen},"} = ", - {call,real_common,encode_real,[Real]},com,nl, - "[",{call,Erules,encode_length,[{curr,tmplen}]},",",nl, - {call,Erules,octets_to_complete, - [{curr,tmplen},{curr,tmpval}]},"]",nl, - "end"]). - -emit_enc_known_multiplier_string(StringType,C,Value) -> - SizeC = effective_constraint(bitstring, C), - PAlphabC = get_constraint(C,'PermittedAlphabet'), - case {StringType,PAlphabC} of - {'UniversalString',{_,_}} -> - exit({error,{asn1,{'not implemented',"UniversalString with " - "PermittedAlphabet constraint"}}}); - {'BMPString',{_,_}} -> - exit({error,{asn1,{'not implemented',"BMPString with " - "PermittedAlphabet constraint"}}}); - _ -> ok - end, - NumBits = get_NumBits(C,StringType), - CharOutTab = get_CharOutTab(C,StringType), - %% NunBits and CharOutTab for chars_encode - emit_enc_k_m_string(SizeC, NumBits, CharOutTab, Value). - -emit_enc_k_m_string(0, _NumBits, _CharOutTab, _Value) -> - emit({"[]"}); -emit_enc_k_m_string(SizeC, NumBits, CharOutTab, Value) -> - call(per, encode_known_multiplier_string, - [{asis,SizeC},NumBits,{asis,CharOutTab},Value]). - - -%% copied from run time module - -get_CharOutTab(C, StringType) -> - case get_constraint(C,'PermittedAlphabet') of - {'SingleValue',Sv} -> - get_CharTab2(C, StringType, hd(Sv), lists:max(Sv), Sv); - no -> - case StringType of - 'IA5String' -> - {0,16#7F,notab}; - 'VisibleString' -> - get_CharTab2(C, StringType, 16#20, 16#7F, notab); - 'PrintableString' -> - Chars = lists:sort( - " '()+,-./0123456789:=?ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"), - get_CharTab2(C, StringType, hd(Chars), - lists:max(Chars), Chars); - 'NumericString' -> - get_CharTab2(C, StringType, 16#20, $9, " 0123456789"); - 'UniversalString' -> - {0,16#FFFFFFFF,notab}; - 'BMPString' -> - {0,16#FFFF,notab} - end - end. - -get_CharTab2(C, StringType, Min, Max, Chars) -> - BitValMax = (1 bsl get_NumBits(C,StringType))-1, - if - Max =< BitValMax -> - {0,Max,notab}; - true -> - {Min,Max,create_char_tab(Min,Chars)} - end. - -create_char_tab(Min,L) -> - list_to_tuple(create_char_tab(Min,L,0)). -create_char_tab(Min,[Min|T],V) -> - [V|create_char_tab(Min+1,T,V+1)]; -create_char_tab(_Min,[],_V) -> - []; -create_char_tab(Min,L,V) -> - [false|create_char_tab(Min+1,L,V)]. - -get_NumBits(C,StringType) -> - case get_constraint(C,'PermittedAlphabet') of - {'SingleValue',Sv} -> - charbits(length(Sv),aligned); - no -> - case StringType of - 'IA5String' -> - charbits(128,aligned); % 16#00..16#7F - 'VisibleString' -> - charbits(95,aligned); % 16#20..16#7E - 'PrintableString' -> - charbits(74,aligned); % [$\s,$',$(,$),$+,$,,$-,$.,$/,"0123456789",$:,$=,$?,$A..$Z,$a..$z - 'NumericString' -> - charbits(11,aligned); % $ ,"0123456789" - 'UniversalString' -> - 32; - 'BMPString' -> - 16 - end - end. - -charbits(NumOfChars,aligned) -> - case charbits(NumOfChars) of - 1 -> 1; - 2 -> 2; - B when B =< 4 -> 4; - B when B =< 8 -> 8; - B when B =< 16 -> 16; - B when B =< 32 -> 32 - end. - -charbits(NumOfChars) when NumOfChars =< 2 -> 1; -charbits(NumOfChars) when NumOfChars =< 4 -> 2; -charbits(NumOfChars) when NumOfChars =< 8 -> 3; -charbits(NumOfChars) when NumOfChars =< 16 -> 4; -charbits(NumOfChars) when NumOfChars =< 32 -> 5; -charbits(NumOfChars) when NumOfChars =< 64 -> 6; -charbits(NumOfChars) when NumOfChars =< 128 -> 7; -charbits(NumOfChars) when NumOfChars =< 256 -> 8; -charbits(NumOfChars) when NumOfChars =< 512 -> 9; -charbits(NumOfChars) when NumOfChars =< 1024 -> 10; -charbits(NumOfChars) when NumOfChars =< 2048 -> 11; -charbits(NumOfChars) when NumOfChars =< 4096 -> 12; -charbits(NumOfChars) when NumOfChars =< 8192 -> 13; -charbits(NumOfChars) when NumOfChars =< 16384 -> 14; -charbits(NumOfChars) when NumOfChars =< 32768 -> 15; -charbits(NumOfChars) when NumOfChars =< 65536 -> 16; -charbits(NumOfChars) when is_integer(NumOfChars) -> - 16 + charbits1(NumOfChars bsr 16). - -charbits1(0) -> - 0; -charbits1(NumOfChars) -> - 1 + charbits1(NumOfChars bsr 1). - -%% copied from run time module - -emit_enc_octet_string(Erules, Constraint, Value) -> - case effective_constraint(bitstring, Constraint) of - 0 -> - emit({" []"}); - 1 -> - asn1ct_name:new(tmpval), - emit({" begin",nl}), - emit({" [",{curr,tmpval},"] = ",Value,",",nl}), - emit([" [[10,8],",{curr,tmpval},"]",nl]), - emit(" end"); - 2 -> - asn1ct_name:new(tmpval), - emit([" begin",nl, - " ",{curr,tmpval}," = ",Value,",",nl, - " case length(",{curr,tmpval},") of",nl, - " 2 ->",nl, - " [[45,16,2]|",{curr,tmpval},"];",nl, - " _ ->",nl, - " exit({error,{value_out_of_bounds,", - {curr,tmpval},"}})",nl, - " end",nl, - " end"]); - Sv when is_integer(Sv), Sv < 256 -> - asn1ct_name:new(tmpval), - asn1ct_name:new(tmplen), - emit([" begin",nl, - " ",{curr,tmpval}," = ",Value,",",nl, - " case length(",{curr,tmpval},") of",nl, - " ",Sv,"=",{curr,tmplen}," ->",nl, - " [20,",{curr,tmplen},"|",{curr,tmpval},"];",nl, - " _ ->",nl, - " exit({error,{value_out_of_bounds,", - {curr,tmpval},"}})",nl, - " end",nl, - " end"]); - Sv when is_integer(Sv),Sv =< 65535 -> - asn1ct_name:new(tmpval), - asn1ct_name:new(tmplen), - emit([" begin",nl, - " ",{curr,tmpval}," = ",Value,",",nl, - " case length(",{curr,tmpval},") of",nl, - " ",Sv,"=",{curr,tmplen}," ->",nl, - " [<<21,",{curr,tmplen},":16>>|",Value,"];",nl, - " _ ->",nl, - " exit({error,{value_out_of_bounds,", - {curr,tmpval},"}})",nl, - " end",nl, - " end"]); - C -> - call(Erules, encode_octet_string, - [{asis,C},Value]) - end. - -emit_enc_integer_case(Value) -> - case get(component_type) of - {true,#'ComponentType'{prop=Prop}} -> - emit({" begin",nl}), - case Prop of - Opt when Opt=='OPTIONAL'; - is_tuple(Opt),element(1,Opt)=='DEFAULT' -> - emit({" case ",Value," of",nl}), - ok; - _ -> - emit({" ",{curr,tmpval},"=",Value,",",nl}), - emit({" case ",{curr,tmpval}," of",nl}), - asn1ct_name:new(tmpval) - end; -% asn1ct_name:new(tmpval); - _ -> - emit({" case ",Value," of ",nl}) - end. -emit_enc_integer_end_case() -> - case get(component_type) of - {true,_} -> - emit({nl," end"}); % end of begin ... end - _ -> ok - end. - - -emit_enc_integer_NNL(Erules,C,Value,NNL) -> - EncVal = enc_integer_NNL_cases(Value,NNL), - emit_enc_integer(Erules,C,EncVal). - -enc_integer_NNL_cases(Value,NNL) -> - asn1ct_name:new(tmpval), - TmpVal = asn1ct_gen:mk_var(asn1ct_name:curr(tmpval)), - Cases=enc_integer_NNL_cases1(NNL), - lists:flatten(io_lib:format("(case ~s of "++Cases++ - "~s when is_atom(~s)->exit({error,{asn1,{namednumber,~s}}});_->~s end)",[Value,TmpVal,TmpVal,TmpVal,Value])). - -enc_integer_NNL_cases1([{NNo,No}|Rest]) -> - io_lib:format("~w->~w;",[NNo,No])++enc_integer_NNL_cases1(Rest); -enc_integer_NNL_cases1([]) -> - "". - -emit_enc_integer(_Erule,[{'SingleValue',Int}],Value) -> - asn1ct_name:new(tmpval), - emit_enc_integer_case(Value),% emit([" case ",Value," of",nl]), - emit([" ",Int," -> [];",nl]), - emit([" ",{curr,tmpval}," ->",nl]), - emit([" exit({error,{value_out_of_bounds,",{curr,tmpval},"}})", - nl," end",nl]), - emit_enc_integer_end_case(); - -emit_enc_integer(_Erule,[{_,{Lb,Ub},_Range,{bits,NoBs}}],Value) -> % Range =< 255 - asn1ct_name:new(tmpval), - emit_enc_integer_case(Value), - emit([" ",{curr,tmpval}," when ",{curr,tmpval},"=<",Ub,",", - {curr,tmpval},">=",Lb," ->",nl]), - emit([" [10,",NoBs,",",{curr,tmpval},"- ",Lb,"];",nl]), - emit([" ",{curr,tmpval}," ->",nl]), - emit([" exit({error,{value_out_of_bounds,", - {curr,tmpval},"}})",nl," end",nl]), - emit_enc_integer_end_case(); - -emit_enc_integer(_Erule,[{_,{Lb,Ub},Range,_}],Value) when Range =< 256 -> - asn1ct_name:new(tmpval), - emit_enc_integer_case(Value), - emit([" ",{curr,tmpval}," when ",{curr,tmpval},"=<",Ub,",", - {curr,tmpval},">=",Lb," ->",nl]), - emit([" [20,1,",{curr,tmpval},"- ",Lb,"];",nl]), - emit([" ",{curr,tmpval}," ->",nl]), - emit([" exit({error,{value_out_of_bounds,",{curr,tmpval},"}})", - nl," end",nl]), - emit_enc_integer_end_case(); - -emit_enc_integer(_Erule,[{_,{Lb,Ub},Range,_}],Value) when Range =< 65536 -> - asn1ct_name:new(tmpval), - emit_enc_integer_case(Value), - emit([" ",{curr,tmpval}," when ",{curr,tmpval},"=<",Ub,",", - {curr,tmpval},">=",Lb," ->",nl]), - emit([" [20,2,<<(",{curr,tmpval},"- ",Lb,"):16>>];",nl]), - emit([" ",{curr,tmpval}," ->",nl]), - emit([" exit({error,{value_out_of_bounds,",{curr,tmpval},"}})", - nl," end",nl]), - emit_enc_integer_end_case(); - -emit_enc_integer(Erule, [{'ValueRange',{Lb,Ub}=VR}], Value) - when is_integer(Lb), is_integer(Ub) -> - call(Erule, encode_constrained_number, [{asis,VR},Value]); - -emit_enc_integer(Erule, C, Value) -> - call(Erule, encode_integer, [{asis,C},Value]). - - -get_constraint([{Key,V}],Key) -> - V; -get_constraint([],_) -> - no; -get_constraint(C,Key) -> - case lists:keysearch(Key,1,C) of - false -> - no; - {value,{_,V}} -> - V - end. - -%% effective_constraint(Type,C) -%% Type = atom() -%% C = [C1,...] -%% C1 = {'SingleValue',SV} | {'ValueRange',VR} | {atom(),term()} -%% SV = integer() | [integer(),...] -%% VR = {Lb,Ub} -%% Lb = 'MIN' | integer() -%% Ub = 'MAX' | integer() -%% Returns a single value if C only has a single value constraint, and no -%% value range constraints, that constrains to a single value, otherwise -%% returns a value range that has the lower bound set to the lowest value -%% of all single values and lower bound values in C and the upper bound to -%% the greatest value. -effective_constraint(integer,[C={{_,_},_}|_Rest]) -> % extension - [C]; %% [C|effective_constraint(integer,Rest)]; XXX what is possible ??? -effective_constraint(integer,C) -> - pre_encode(integer, asn1ct_imm:effective_constraint(integer, C)); -effective_constraint(bitstring,C) -> - asn1ct_imm:effective_constraint(bitstring, C). - -pre_encode(integer,[]) -> - []; -pre_encode(integer,C=[{'SingleValue',_}]) -> - C; -pre_encode(integer,C=[{'ValueRange',VR={Lb,Ub}}]) when is_integer(Lb),is_integer(Ub)-> - Range = Ub-Lb+1, - if - Range =< 255 -> - NoBits = no_bits(Range), - [{'ValueRange',VR,Range,{bits,NoBits}}]; - Range =< 256 -> - [{'ValueRange',VR,Range,{octets,1}}]; - Range =< 65536 -> - [{'ValueRange',VR,Range,{octets,2}}]; - true -> - C - end; -pre_encode(integer,C) -> - C. - -no_bits(2) -> 1; -no_bits(N) when N=<4 -> 2; -no_bits(N) when N=<8 -> 3; -no_bits(N) when N=<16 -> 4; -no_bits(N) when N=<32 -> 5; -no_bits(N) when N=<64 -> 6; -no_bits(N) when N=<128 -> 7; -no_bits(N) when N=<255 -> 8. diff --git a/lib/asn1/src/asn1ct_imm.erl b/lib/asn1/src/asn1ct_imm.erl index bf362db843..892178f61b 100644 --- a/lib/asn1/src/asn1ct_imm.erl +++ b/lib/asn1/src/asn1ct_imm.erl @@ -26,6 +26,18 @@ per_dec_octet_string/2,per_dec_open_type/1,per_dec_real/1, per_dec_restricted_string/1]). -export([per_dec_constrained/3,per_dec_normally_small_number/1]). +-export([per_enc_bit_string/4,per_enc_boolean/2, + per_enc_choice/3,per_enc_enumerated/3, + per_enc_integer/3,per_enc_integer/4, + per_enc_null/2, + per_enc_k_m_string/4,per_enc_octet_string/3, + per_enc_open_type/2, + per_enc_restricted_string/3, + per_enc_small_number/2]). +-export([per_enc_extension_bit/2,per_enc_extensions/4,per_enc_optional/3]). +-export([per_enc_sof/5]). +-export([enc_absent/3,enc_append/1,enc_bind_var/1]). +-export([enc_cg/2]). -export([optimize_alignment/1,optimize_alignment/2, dec_slim_cg/2,dec_code_gen/2]). -export([effective_constraint/2]). @@ -115,29 +127,18 @@ per_dec_named_integer(Constraint, NamedList0, Aligned) -> per_dec_k_m_string(StringType, Constraint, Aligned) -> SzConstr = effective_constraint(bitstring, Constraint), N = string_num_bits(StringType, Constraint, Aligned), - %% X.691 (07/2002) 27.5.7 says if the upper bound times the number - %% of bits is greater than or equal to 16, then the bit field should - %% be aligned. - Imm = dec_string(SzConstr, N, Aligned, fun(_, Ub) -> Ub >= 16 end), + Imm = dec_string(SzConstr, N, Aligned, k_m_string), Chars = char_tab(Constraint, StringType, N), convert_string(N, Chars, Imm). per_dec_octet_string(Constraint, Aligned) -> - dec_string(Constraint, 8, Aligned, - %% Aligned unless the size is fixed and =< 16. - fun(Sv, Sv) -> Sv > 16; - (_, _) -> true - end). + dec_string(Constraint, 8, Aligned, 'OCTET STRING'). per_dec_raw_bitstring(Constraint, Aligned) -> - dec_string(Constraint, 1, Aligned, - fun(Sv, Sv) -> Sv > 16; - (_, _) -> true - end). + dec_string(Constraint, 1, Aligned, 'BIT STRING'). per_dec_open_type(Aligned) -> - {get_bits,decode_unconstrained_length(true, Aligned), - [8,binary,{align,Aligned}]}. + dec_string(no, 8, Aligned, open_type). per_dec_real(Aligned) -> Dec = fun(V, Buf) -> @@ -152,26 +153,285 @@ per_dec_restricted_string(Aligned) -> DecLen = decode_unconstrained_length(true, Aligned), {get_bits,DecLen,[8,binary]}. +%%% +%%% Encoding. +%%% + +per_enc_bit_string(Val0, [], Constraint0, Aligned) -> + {B,[Val,Bs,Bits]} = mk_vars(Val0, [bs,bits]), + Constraint = effective_constraint(bitstring, Constraint0), + ExtraArgs = case constr_min_size(Constraint) of + no -> []; + Lb -> [Lb] + end, + B ++ [{call,per_common,to_bitstring,[Val|ExtraArgs],Bs}, + {call,erlang,bit_size,[Bs],Bits}| + per_enc_length(Bs, 1, Bits, Constraint, Aligned, 'BIT STRING')]; +per_enc_bit_string(Val0, NNL0, Constraint0, Aligned) -> + {B,[Val,Bs,Bits,Positions]} = mk_vars(Val0, [bs,bits,positions]), + NNL = lists:keysort(2, NNL0), + Constraint = effective_constraint(bitstring, Constraint0), + ExtraArgs = case constr_min_size(Constraint) of + no -> []; + Lb -> [Lb] + end, + B ++ [{'try', + [bit_string_name2pos_fun(NNL, Val)], + {Positions, + [{call,per_common,bitstring_from_positions, + [Positions|ExtraArgs]}]}, + [{call,per_common,to_named_bitstring,[Val|ExtraArgs]}],Bs}, + {call,erlang,bit_size,[Bs],Bits}| + per_enc_length(Bs, 1, Bits, Constraint, Aligned, 'BIT STRING')]. + +per_enc_boolean(Val0, _Aligned) -> + {B,[Val]} = mk_vars(Val0, []), + B++build_cond([[{eq,Val,false},{put_bits,0,1,[1]}], + [{eq,Val,true},{put_bits,1,1,[1]}]]). + +per_enc_choice(Val0, Cs0, _Aligned) -> + {B,[Val]} = mk_vars(Val0, []), + Cs = [[{eq,Val,Tag}|opt_choice(Imm)] || {Tag,Imm} <- Cs0], + B++build_cond(Cs). + +per_enc_enumerated(Val0, {Root,Ext}, Aligned) -> + {B,[Val]} = mk_vars(Val0, []), + Constr = enumerated_constraint(Root), + RootCs = per_enc_enumerated_root(Root, [{put_bits,0,1,[1]}], + Val, Constr, Aligned), + ExtCs = per_enc_enumerated_ext(Ext, Val, Aligned), + B++[{'cond',RootCs++ExtCs++enumerated_error(Val)}]; +per_enc_enumerated(Val0, Root, Aligned) -> + {B,[Val]} = mk_vars(Val0, []), + Constr = enumerated_constraint(Root), + Cs = per_enc_enumerated_root(Root, [], Val, Constr, Aligned), + B++[{'cond',Cs++enumerated_error(Val)}]. + +enumerated_error(Val) -> + [['_',{error,Val}]]. + +per_enc_integer(Val0, Constraint0, Aligned) -> + {B,[Val]} = mk_vars(Val0, []), + Constraint = effective_constraint(integer, Constraint0), + B ++ per_enc_integer_1(Val, Constraint, Aligned). + +per_enc_integer(Val0, NNL, Constraint0, Aligned) -> + {B,[Val]} = mk_vars(Val0, []), + Constraint = effective_constraint(integer, Constraint0), + Cs = [[{eq,Val,N}|per_enc_integer_1(V, Constraint, Aligned)] || + {N,V} <- NNL], + case per_enc_integer_1(Val, Constraint, Aligned) of + [{'cond',IntCs}] -> + B ++ [{'cond',Cs++IntCs}]; + Other -> + B ++ [{'cond',Cs++[['_'|Other]]}] + end. + +per_enc_null(_Val, _Aligned) -> + []. + +per_enc_k_m_string(Val0, StringType, Constraint, Aligned) -> + {B,[Val,Bin,Len]} = mk_vars(Val0, [bin,len]), + SzConstraint = effective_constraint(bitstring, Constraint), + Unit = string_num_bits(StringType, Constraint, Aligned), + Chars0 = char_tab(Constraint, StringType, Unit), + Args = case enc_char_tab(Chars0) of + notab -> [Val,Unit]; + Chars -> [Val,Unit,Chars] + end, + Enc = case Unit of + 16 -> + {call,per_common,encode_chars_16bit,[Val],Bin}; + 32 -> + {call,per_common,encode_big_chars,[Val],Bin}; + 8 -> + {call,erlang,list_to_binary,[Val],Bin}; + _ -> + {call,per_common,encode_chars,Args,Bin} + end, + case Unit of + 8 -> + B ++ [Enc,{call,erlang,byte_size,[Bin],Len}]; + _ -> + B ++ [{call,erlang,length,[Val],Len},Enc] + end ++ per_enc_length(Bin, Unit, Len, SzConstraint, Aligned, k_m_string). + +per_enc_open_type([], Aligned) -> + [{put_bits,1,8,unit(1, Aligned)},{put_bits,0,8,[1]}]; +per_enc_open_type([{'cond', + [['_', + {put_bits,0,0,_}, + {call,per_common,encode_unconstrained_number,_}=Call]]}], + Aligned) -> + %% We KNOW that encode_unconstrained_number/1 will return an IO list; + %% therefore the call to complete/1 can be replaced with a cheaper + %% call to iolist_to_binary/1. + {Dst,Imm} = per_enc_open_type_output([Call], []), + ToBin = {erlang,iolist_to_binary}, + Imm ++ per_enc_open_type(Dst, ToBin, Aligned); +per_enc_open_type([{call,erlang,iolist_to_binary,Args}], Aligned) -> + {_,[_,Bin,Len]} = mk_vars('dummy', [bin,len]), + [{call,erlang,iolist_to_binary,Args,Bin}, + {call,erlang,byte_size,[Bin],Len}|per_enc_length(Bin, 8, Len, Aligned)]; +per_enc_open_type(Imm0, Aligned) -> + try + {Prefix,Imm1} = split_off_nonbuilding(Imm0), + Prefix ++ enc_open_type(Imm1, Aligned) + catch + throw:impossible -> + {Dst,Imm} = per_enc_open_type_output(Imm0, []), + ToBin = {enc_mod(Aligned),complete}, + Imm ++ per_enc_open_type(Dst, ToBin, Aligned) + end. + +per_enc_octet_string(Val0, Constraint0, Aligned) -> + {B,[Val,Bin,Len]} = mk_vars(Val0, [bin,len]), + Constraint = effective_constraint(bitstring, Constraint0), + B ++ [{call,erlang,iolist_to_binary,[Val],Bin}, + {call,erlang,byte_size,[Bin],Len}| + per_enc_length(Bin, 8, Len, Constraint, Aligned, 'OCTET STRING')]. + +per_enc_restricted_string(Val0, {M,F}, Aligned) -> + {B,[Val,Bin,Len]} = mk_vars(Val0, [bin,len]), + B ++ [{call,M,F,[Val],Bin}, + {call,erlang,byte_size,[Bin],Len}| + per_enc_length(Bin, 8, Len, Aligned)]. + +per_enc_small_number(Val, Aligned) -> + build_cond([[{lt,Val,64},{put_bits,Val,7,[1]}], + ['_',{put_bits,1,1,[1]}| + per_enc_unsigned(Val, Aligned)]]). + +per_enc_extension_bit(Val0, _Aligned) -> + {B,[Val]} = mk_vars(Val0, []), + B++build_cond([[{eq,Val,[]},{put_bits,0,1,[1]}], + ['_',{put_bits,1,1,[1]}]]). + +per_enc_extensions(Val0, Pos0, NumBits, Aligned) when NumBits > 0 -> + Pos = Pos0 + 1, + {B,[Val,Bitmap]} = mk_vars(Val0, [bitmap]), + Length = per_enc_small_length(NumBits, Aligned), + PutBits = case NumBits of + 1 -> [{put_bits,1,1,[1]}]; + _ -> [{put_bits,Bitmap,NumBits,[1]}] + end, + B++[{call,per_common,extension_bitmap,[Val,Pos,Pos+NumBits],Bitmap}, + {'cond',[[{eq,Bitmap,0}], + ['_'|Length ++ PutBits]],{var,"Extensions"}}]. + +per_enc_optional(Val0, {Pos,Def}, _Aligned) when is_integer(Pos) -> + Val1 = lists:concat(["element(",Pos,", ",Val0,")"]), + {B,[Val]} = mk_vars(Val1, []), + Zero = {put_bits,0,1,[1]}, + One = {put_bits,1,1,[1]}, + B++[{'cond',[[{eq,Val,asn1_DEFAULT},Zero], + [{eq,Val,Def},Zero], + ['_',One]]}]; +per_enc_optional(Val0, Pos, _Aligned) when is_integer(Pos) -> + Val1 = lists:concat(["element(",Pos,", ",Val0,")"]), + {B,[Val]} = mk_vars(Val1, []), + Zero = {put_bits,0,1,[1]}, + One = {put_bits,1,1,[1]}, + B++[{'cond',[[{eq,Val,asn1_NOVALUE},Zero], + ['_',One]]}]. + +per_enc_sof(Val0, Constraint, ElementVar, ElementImm, Aligned) -> + {B,[Val,Len]} = mk_vars(Val0, [len]), + SzConstraint = effective_constraint(bitstring, Constraint), + LenImm = enc_length(Len, SzConstraint, Aligned), + Lc0 = [{lc,ElementImm,{var,atom_to_list(ElementVar)},Val}], + Lc = opt_lc(Lc0, LenImm), + PreBlock = B ++ [{call,erlang,length,[Val],Len}], + case LenImm of + [{'cond',[[C|Action]]}] -> + PreBlock ++ [{'cond',[[C|Action++Lc]]}]; + [{sub,_,_,_}=Sub,{'cond',[[C|Action]]}] -> + PreBlock ++ + [Sub,{'cond',[[C|Action++Lc]]}]; + EncLen -> + PreBlock ++ EncLen ++ Lc + end. + +enc_absent(Val0, AbsVals, Body) -> + {B,[Var]} = mk_vars(Val0, []), + Cs = [[{eq,Var,Aval}] || Aval <- AbsVals] ++ [['_'|Body]], + B++build_cond(Cs). + +enc_append([[]|T]) -> + enc_append(T); +enc_append([[{put_bits,_,_,_}|_]=Pb|[Imm|T]=T0]) -> + case opt_choice(Pb++Imm) of + [{put_bits,_,_,_}|_] -> + [{block,Pb}|enc_append(T0)]; + Opt -> + enc_append([Opt|T]) + end; +enc_append([Imm0|[Imm1|T]=T0]) -> + try combine_imms(Imm0, Imm1) of + Imm -> + enc_append([Imm|T]) + catch + throw:impossible -> + [{block,Imm0}|enc_append(T0)] + end; +enc_append([H|T]) -> + [{block,H}|enc_append(T)]; +enc_append([]) -> []. + +enc_bind_var(Val) -> + {B,[{var,Var}]} = mk_vars(Val, []), + {B,list_to_atom(Var)}. + +enc_cg(Imm0, false) -> + Imm1 = enc_cse(Imm0), + Imm = enc_pre_cg(Imm1), + enc_cg(Imm); +enc_cg(Imm0, true) -> + Imm1 = enc_cse(Imm0), + Imm2 = enc_hoist_align(Imm1), + Imm3 = enc_opt_al(Imm2), + Imm4 = per_fixup(Imm3), + Imm = enc_pre_cg(Imm4), + enc_cg(Imm). %%% %%% Local functions. %%% -dec_string(Sv, U, Aligned0, AF) when is_integer(Sv) -> +%% is_aligned(StringType, LowerBound, UpperBound) -> boolean() +%% StringType = 'OCTET STRING' | 'BIT STRING' | k_m_string +%% LowerBound = UpperBound = number of bits +%% Determine whether a string should be aligned in PER. + +is_aligned(T, Lb, Ub) when T =:= 'OCTET STRING'; T =:= 'BIT STRING' -> + %% OCTET STRINGs and BIT STRINGs are aligned to a byte boundary + %% unless the size is fixed and less than or equal to 16 bits. + Lb =/= Ub orelse Lb > 16; +is_aligned(k_m_string, _Lb, Ub) -> + %% X.691 (07/2002) 27.5.7 says if the upper bound times the number + %% of bits is greater than or equal to 16, then the bit field should + %% be aligned. + Ub >= 16. + +%%% +%%% Generating the intermediate format format for decoding. +%%% + +dec_string(Sv, U, Aligned0, T) when is_integer(Sv) -> Bits = U*Sv, - Aligned = Aligned0 andalso AF(Bits, Bits), + Aligned = Aligned0 andalso is_aligned(T, Bits, Bits), {get_bits,Sv,[U,binary,{align,Aligned}]}; -dec_string({{Sv,Sv},[]}, U, Aligned, AF) -> - bit_case(dec_string(Sv, U, Aligned, AF), - dec_string(no, U, Aligned, AF)); -dec_string({{_,_}=C,[]}, U, Aligned, AF) -> - bit_case(dec_string(C, U, Aligned, AF), - dec_string(no, U, Aligned, AF)); -dec_string({Lb,Ub}, U, Aligned0, AF) -> +dec_string({{Sv,Sv},[]}, U, Aligned, T) -> + bit_case(dec_string(Sv, U, Aligned, T), + dec_string(no, U, Aligned, T)); +dec_string({{_,_}=C,[]}, U, Aligned, T) -> + bit_case(dec_string(C, U, Aligned, T), + dec_string(no, U, Aligned, T)); +dec_string({Lb,Ub}, U, Aligned0, T) -> Len = per_dec_constrained(Lb, Ub, Aligned0), - Aligned = Aligned0 andalso AF(Lb*U, Ub*U), + Aligned = Aligned0 andalso is_aligned(T, Lb*U, Ub*U), {get_bits,Len,[U,binary,{align,Aligned}]}; -dec_string(_, U, Aligned, _AF) -> +dec_string(_, U, Aligned, _T) -> Al = [{align,Aligned}], DecRest = fun(V, Buf) -> asn1ct_func:call(per_common, @@ -692,6 +952,1164 @@ mk_dest(I) when is_integer(I) -> integer_to_list(I); mk_dest(S) -> S. +%%% +%%% Constructing the intermediate format for encoding. +%%% + +split_off_nonbuilding(Imm) -> + lists:splitwith(fun is_nonbuilding/1, Imm). + +is_nonbuilding({apply,_,_,_}) -> true; +is_nonbuilding({assign,_,_}) -> true; +is_nonbuilding({call,_,_,_,_}) -> true; +is_nonbuilding({'cond',_,_}) -> true; +is_nonbuilding({lc,_,_,_,_}) -> true; +is_nonbuilding({sub,_,_,_}) -> true; +is_nonbuilding({'try',_,_,_,_}) -> true; +is_nonbuilding(_) -> false. + +mk_vars(Input0, Temps) -> + asn1ct_name:new(enc), + Curr = asn1ct_name:curr(enc), + [H|T] = atom_to_list(Curr), + Base = [H - ($a - $A)|T ++ "@"], + if + is_atom(Input0) -> + Input = {var,atom_to_list(Input0)}, + {[],[Input|mk_vars_1(Base, Temps)]}; + is_integer(Input0) -> + {[],[Input0|mk_vars_1(Base, Temps)]}; + Input0 =:= [] -> + {[],[Input0|mk_vars_1(Base, Temps)]}; + true -> + Input = mk_var(Base, input), + {[{assign,Input,Input0}],[Input|mk_vars_1(Base, Temps)]} + end. + +mk_vars_1(Base, Vars) -> + [mk_var(Base, V) || V <- Vars]. + +mk_var(Base, V) -> + {var,Base ++ atom_to_list(V)}. + +per_enc_integer_1(Val, [], Aligned) -> + [{'cond',[['_'|per_enc_unconstrained(Val, Aligned)]]}]; +per_enc_integer_1(Val0, [{{_,_}=Constr,[]}], Aligned) -> + {Prefix,Check,Action} = per_enc_integer_2(Val0, Constr, Aligned), + Prefix++build_cond([[Check,{put_bits,0,1,[1]}|Action], + ['_',{put_bits,1,1,[1]}| + per_enc_unconstrained(Val0, Aligned)]]); +per_enc_integer_1(Val0, [Constr], Aligned) -> + {Prefix,Check,Action} = per_enc_integer_2(Val0, Constr, Aligned), + Prefix++build_cond([[Check|Action], + ['_',{error,Val0}]]). + +per_enc_integer_2(Val, {'SingleValue',Sv}, Aligned) -> + per_enc_constrained(Val, Sv, Sv, Aligned); +per_enc_integer_2(Val0, {'ValueRange',{Lb,'MAX'}}, Aligned) + when is_integer(Lb) -> + {Prefix,Val} = sub_lb(Val0, Lb), + {Prefix,{ge,Val,0},per_enc_unsigned(Val, Aligned)}; +per_enc_integer_2(Val, {'ValueRange',{Lb,Ub}}, Aligned) + when is_integer(Lb), is_integer(Ub) -> + per_enc_constrained(Val, Lb, Ub, Aligned). + +per_enc_constrained(Val, Sv, Sv, _Aligned) -> + {[],{eq,Val,Sv},[]}; +per_enc_constrained(Val0, Lb, Ub, false) -> + {Prefix,Val} = sub_lb(Val0, Lb), + Range = Ub - Lb + 1, + NumBits = uper_num_bits(Range), + Check = {ult,Val,Range}, + Put = [{put_bits,Val,NumBits,[1]}], + {Prefix,Check,Put}; +per_enc_constrained(Val0, Lb, Ub, true) -> + {Prefix,Val} = sub_lb(Val0, Lb), + Range = Ub - Lb + 1, + if + Range < 256 -> + NumBits = per_num_bits(Range), + Check = {ult,Val,Range}, + Put = [{put_bits,Val,NumBits,[1]}], + {Prefix,Check,Put}; + Range =:= 256 -> + NumBits = 8, + Check = {ult,Val,Range}, + Put = [{put_bits,Val,NumBits,[1,align]}], + {Prefix,Check,Put}; + Range =< 65536 -> + Check = {ult,Val,Range}, + Put = [{put_bits,Val,16,[1,align]}], + {Prefix,Check,Put}; + true -> + {var,VarBase} = Val, + Bin = {var,VarBase++"@bin"}, + BinSize0 = {var,VarBase++"@bin_size0"}, + BinSize = {var,VarBase++"@bin_size"}, + Check = {ult,Val,Range}, + RangeOctsLen = byte_size(binary:encode_unsigned(Range - 1)), + BitsNeeded = per_num_bits(RangeOctsLen), + Enc = [{call,binary,encode_unsigned,[Val],Bin}, + {call,erlang,byte_size,[Bin],BinSize0}, + {sub,BinSize0,1,BinSize}, + {'cond',[['_', + {put_bits,BinSize,BitsNeeded,[1]}, + {put_bits,Bin,binary,[8,align]}]]}], + {Prefix,Check,Enc} + end. + +per_enc_unconstrained(Val, Aligned) -> + case Aligned of + false -> []; + true -> [{put_bits,0,0,[1,align]}] + end ++ [{call,per_common,encode_unconstrained_number,[Val]}]. + +per_enc_unsigned(Val, Aligned) -> + case is_integer(Val) of + false -> + {var,VarBase} = Val, + Bin = {var,VarBase++"@bin"}, + BinSize = {var,VarBase++"@bin_size"}, + [{call,binary,encode_unsigned,[Val],Bin}, + {call,erlang,byte_size,[Bin],BinSize}| + per_enc_length(Bin, 8, BinSize, Aligned)]; + true -> + Bin = binary:encode_unsigned(Val), + Len = byte_size(Bin), + per_enc_length(Bin, 8, Len, Aligned) + end. + +%% Encode a length field without any constraint. +per_enc_length(Bin, Unit, Len, Aligned) -> + U = unit(1, Aligned), + PutBits = put_bits_binary(Bin, Unit, Aligned), + EncFragmented = {call,per_common,encode_fragmented,[Bin,Unit]}, + Al = case Aligned of + false -> []; + true -> [{put_bits,0,0,[1,align]}] + end, + build_cond([[{lt,Len,128}, + {put_bits,Len,8,U},PutBits], + [{lt,Len,16384}, + {put_bits,2,2,U},{put_bits,Len,14,[1]},PutBits], + ['_'|Al++[EncFragmented]]]). + +per_enc_length(Bin, Unit, Len, no, Aligned, _Type) -> + per_enc_length(Bin, Unit, Len, Aligned); +per_enc_length(Bin, Unit, Len, {{Lb,Ub},[]}, Aligned, Type) -> + {Prefix,Check,PutLen} = per_enc_constrained(Len, Lb, Ub, Aligned), + NoExt = {put_bits,0,1,[1]}, + U = unit(Unit, Aligned, Type, Lb*Unit, Ub*Unit), + PutBits = [{put_bits,Bin,binary,U}], + [{'cond',ExtConds0}] = per_enc_length(Bin, Unit, Len, Aligned), + Ext = {put_bits,1,1,[1]}, + ExtConds = prepend_to_cond(ExtConds0, Ext), + build_length_cond(Prefix, [[Check,NoExt|PutLen++PutBits]|ExtConds]); +per_enc_length(Bin, Unit, Len, {Lb,Ub}, Aligned, Type) + when is_integer(Lb) -> + {Prefix,Check,PutLen} = per_enc_constrained(Len, Lb, Ub, Aligned), + U = unit(Unit, Aligned, Type, Lb*Unit, Ub*Unit), + PutBits = [{put_bits,Bin,binary,U}], + build_length_cond(Prefix, [[Check|PutLen++PutBits]]); +per_enc_length(Bin, Unit, Len, Sv, Aligned, Type) when is_integer(Sv) -> + NumBits = Sv*Unit, + U = unit(Unit, Aligned, Type, NumBits, NumBits), + Pb = {put_bits,Bin,binary,U}, + [{'cond',[[{eq,Len,Sv},Pb]]}]. + +enc_length(Len, no, Aligned) -> + U = unit(1, Aligned), + build_cond([[{lt,Len,128}, + {put_bits,Len,8,U}], + [{lt,Len,16384}, + {put_bits,2,2,U},{put_bits,Len,14,[1]}]]); +enc_length(Len, {{Lb,Ub},[]}, Aligned) -> + {Prefix,Check,PutLen} = per_enc_constrained(Len, Lb, Ub, Aligned), + NoExt = {put_bits,0,1,[1]}, + [{'cond',ExtConds0}] = enc_length(Len, no, Aligned), + Ext = {put_bits,1,1,[1]}, + ExtConds = prepend_to_cond(ExtConds0, Ext), + build_length_cond(Prefix, [[Check,NoExt|PutLen]|ExtConds]); +enc_length(Len, {Lb,Ub}, Aligned) when is_integer(Lb) -> + {Prefix,Check,PutLen} = per_enc_constrained(Len, Lb, Ub, Aligned), + build_length_cond(Prefix, [[Check|PutLen]]); +enc_length(Len, Sv, _Aligned) when is_integer(Sv) -> + [{'cond',[[{eq,Len,Sv}]]}]. + +put_bits_binary(Bin, _Unit, Aligned) when is_binary(Bin) -> + Sz = byte_size(Bin), + <<Int:Sz/unit:8>> = Bin, + {put_bits,Int,8*Sz,unit(1, Aligned)}; +put_bits_binary(Bin, Unit, Aligned) -> + {put_bits,Bin,binary,unit(Unit, Aligned)}. + +sub_lb(Val, 0) -> + {[],Val}; +sub_lb({var,Var}=Val0, Lb) -> + Val = {var,Var++"@sub"}, + {[{sub,Val0,Lb,Val}],Val}; +sub_lb(Val, Lb) when is_integer(Val) -> + {[],Val-Lb}. + +build_length_cond([{sub,Var0,Base,Var}]=Prefix, Cs) -> + %% Non-zero lower bound, such as: SIZE (50..200, ...) + Prefix++[{'cond',opt_length_nzlb(Cs, {Var0,Var,Base}, 0)}]; +build_length_cond([], Cs) -> + %% Zero lower bound, such as: SIZE (0..200, ...) + [{'cond',opt_length_zlb(Cs, 0)}]. + +opt_length_zlb([[{ult,Var,Val}|Actions]|T], Ub) -> + %% Since the SIZE constraint is zero-based, Var + %% must be greater than zero, and we can use + %% the slightly cheaper signed less than operator. + opt_length_zlb([[{lt,Var,Val}|Actions]|T], Ub); +opt_length_zlb([[{lt,_,Val}|_]=H|T], Ub) -> + if + Val =< Ub -> + %% A previous test has already matched. + opt_length_zlb(T, Ub); + true -> + [H|opt_length_zlb(T, max(Ub, Val))] + end; +opt_length_zlb([H|T], Ub) -> + [H|opt_length_zlb(T, Ub)]; +opt_length_zlb([], _) -> []. + +opt_length_nzlb([[{ult,Var,Val}|_]=H|T], {_,Var,Base}=St, _Ub) -> + [H|opt_length_nzlb(T, St, Base+Val)]; +opt_length_nzlb([[{lt,Var0,Val}|_]=H|T], {Var0,_,_}=St, Ub) -> + if + Val =< Ub -> + %% A previous test has already matched. + opt_length_nzlb(T, St, Ub); + true -> + [H|opt_length_nzlb(T, St, Val)] + end; +opt_length_nzlb([H|T], St, Ub) -> + [H|opt_length_nzlb(T, St, Ub)]; +opt_length_nzlb([], _, _) -> []. + +build_cond(Conds0) -> + case eval_cond(Conds0, gb_sets:empty()) of + [['_'|Actions]] -> + Actions; + Conds -> + [{'cond',Conds}] + end. + +eval_cond([['_',{'cond',Cs}]], Seen) -> + eval_cond(Cs, Seen); +eval_cond([[Cond|Actions]=H|T], Seen0) -> + case gb_sets:is_element(Cond, Seen0) of + false -> + Seen = gb_sets:insert(Cond, Seen0), + case eval_cond_1(Cond) of + false -> + eval_cond(T, Seen); + true -> + [['_'|Actions]]; + maybe -> + [H|eval_cond(T, Seen)] + end; + true -> + eval_cond(T, Seen0) + end; +eval_cond([], _) -> []. + +eval_cond_1({ult,I,N}) when is_integer(I), is_integer(N) -> + 0 =< I andalso I < N; +eval_cond_1({eq,[],[]}) -> + true; +eval_cond_1({eq,I,N}) when is_integer(I), is_integer(N) -> + I =:= N; +eval_cond_1({lt,I,N}) when is_integer(I), is_integer(N) -> + I < N; +eval_cond_1(_) -> maybe. + +prepend_to_cond([H|T], Code) -> + [prepend_to_cond_1(H, Code)|prepend_to_cond(T, Code)]; +prepend_to_cond([], _) -> []. + +prepend_to_cond_1([Check|T], Code) -> + [Check,Code|T]. + +enc_char_tab(notab) -> + notab; +enc_char_tab(Tab0) -> + Tab = tuple_to_list(Tab0), + First = hd(Tab), + {First-1,list_to_tuple(enc_char_tab_1(Tab, First, 0))}. + +enc_char_tab_1([H|T], H, I) -> + [I|enc_char_tab_1(T, H+1, I+1)]; +enc_char_tab_1([_|_]=T, H, I) -> + [ill|enc_char_tab_1(T, H+1, I)]; +enc_char_tab_1([], _, _) -> []. + +enumerated_constraint([_]) -> + [{'SingleValue',0}]; +enumerated_constraint(Root) -> + [{'ValueRange',{0,length(Root)-1}}]. + +per_enc_enumerated_root(NNL, Prefix, Val, Constr, Aligned) -> + per_enc_enumerated_root_1(NNL, Prefix, Val, Constr, Aligned, 0). + +per_enc_enumerated_root_1([{H,_}|T], Prefix, Val, Constr, Aligned, N) -> + [[{eq,Val,H}|Prefix++per_enc_integer_1(N, Constr, Aligned)]| + per_enc_enumerated_root_1(T, Prefix, Val, Constr, Aligned, N+1)]; +per_enc_enumerated_root_1([], _, _, _, _, _) -> []. + +per_enc_enumerated_ext(NNL, Val, Aligned) -> + per_enc_enumerated_ext_1(NNL, Val, Aligned, 0). + +per_enc_enumerated_ext_1([{H,_}|T], Val, Aligned, N) -> + [[{eq,Val,H},{put_bits,1,1,[1]}|per_enc_small_number(N, Aligned)]| + per_enc_enumerated_ext_1(T, Val, Aligned, N+1)]; +per_enc_enumerated_ext_1([], _, _, _) -> []. + +per_enc_small_length(Val0, Aligned) -> + {Sub,Val} = sub_lb(Val0, 1), + U = unit(1, Aligned), + Sub ++ build_cond([[{lt,Val,64},{put_bits,Val,7,[1]}], + [{lt,Val0,128},{put_bits,1,1,[1]}, + {put_bits,Val0,8,U}], + ['_',{put_bits,1,1,[1]}, + {put_bits,2,2,U},{put_bits,Val0,14,[1]}]]). + +constr_min_size(no) -> no; +constr_min_size({{Lb,_},[]}) when is_integer(Lb) -> Lb; +constr_min_size({Lb,_}) when is_integer(Lb) -> Lb; +constr_min_size(Sv) when is_integer(Sv) -> Sv. + +enc_mod(false) -> uper; +enc_mod(true) -> per. + +unit(U, false) -> [U]; +unit(U, true) -> [U,align]. + +unit(U, Aligned, Type, Lb, Ub) -> + case Aligned andalso is_aligned(Type, Lb, Ub) of + true -> [U,align]; + false -> [U] + end. + +opt_choice(Imm) -> + {Pb,T0} = lists:splitwith(fun({put_bits,V,_,_}) when is_integer(V) -> + true; + (_) -> + false + end, Imm), + try + {Prefix,T} = split_off_nonbuilding(T0), + Prefix ++ opt_choice_1(T, Pb) + catch + throw:impossible -> + Imm + end. + +opt_choice_1([{'cond',Cs0}], Pb) -> + case Cs0 of + [[C|Act]] -> + [{'cond',[[C|Pb++Act]]}]; + [[C|Act],['_',{error,_}]=Error] -> + [{'cond',[[C|Pb++Act],Error]}]; + _ -> + [{'cond',opt_choice_2(Cs0, Pb)}] + end; +opt_choice_1(_, _) -> throw(impossible). + +opt_choice_2([[C|[{put_bits,_,_,_}|_]=Act]|T], Pb) -> + [[C|Pb++Act]|opt_choice_2(T, Pb)]; +opt_choice_2([[_,{error,_}]=H|T], Pb) -> + [H|opt_choice_2(T, Pb)]; +opt_choice_2([_|_], _) -> + throw(impossible); +opt_choice_2([], _) -> []. + + +%%% +%%% Helper functions for code generation of open types. +%%% + +per_enc_open_type(Val0, {ToBinMod,ToBinFunc}, Aligned) -> + {B,[Val,Len,Bin]} = mk_vars(Val0, [len,bin]), + B ++ [{call,ToBinMod,ToBinFunc,[Val],Bin}, + {call,erlang,byte_size,[Bin],Len}| + per_enc_length(Bin, 8, Len, Aligned)]. + +enc_open_type([{'cond',Cs}], Aligned) -> + [{'cond',[[C|enc_open_type_1(Act, Aligned)] || [C|Act] <- Cs]}]; +enc_open_type(_, _) -> + throw(impossible). + +enc_open_type_1([{error,_}]=Imm, _) -> + Imm; +enc_open_type_1(Imm, Aligned) -> + NumBits = num_bits(Imm, 0), + Pad = case 8 - (NumBits rem 8) of + 8 -> []; + Pad0 -> [{put_bits,0,Pad0,[1]}] + end, + NumBytes = (NumBits+7) div 8, + enc_length(NumBytes, no, Aligned) ++ Imm ++ Pad. + +num_bits([{put_bits,_,N,[U|_]}|T], Sum) when is_integer(N) -> + num_bits(T, Sum+N*U); +num_bits([_|_], _) -> + throw(impossible); +num_bits([], Sum) -> Sum. + +per_enc_open_type_output([{apply,F,A}], Acc) -> + Dst = output_var(), + {Dst,lists:reverse(Acc, [{apply,F,A,{var,atom_to_list(Dst)}}])}; +per_enc_open_type_output([{call,M,F,A}], Acc) -> + Dst = output_var(), + {Dst,lists:reverse(Acc, [{call,M,F,A,{var,atom_to_list(Dst)}}])}; +per_enc_open_type_output([{'cond',Cs}], Acc) -> + Dst = output_var(), + {Dst,lists:reverse(Acc, [{'cond',Cs,{var,atom_to_list(Dst)}}])}; +per_enc_open_type_output([H|T], Acc) -> + per_enc_open_type_output(T, [H|Acc]). + +output_var() -> + asn1ct_name:new(enc), + Curr = asn1ct_name:curr(enc), + [H|T] = atom_to_list(Curr), + list_to_atom([H - ($a - $A)|T ++ "@output"]). + + +%%% +%%% Optimize list comprehensions (SEQUENCE OF/SET OF). +%%% + +opt_lc([{lc,[{call,erlang,iolist_to_binary,[Var],Bin}, + {call,erlang,byte_size,[Bin],LenVar}, + {'cond',[[{eq,LenVar,Len},{put_bits,Bin,_,[_|Align]}]]}], + Var,Val}]=Lc, LenImm) -> + %% Given a sequence of a fixed length string, such as + %% SEQUENCE OF OCTET STRING (SIZE (4)), attempt to rewrite to + %% a list comprehension that just checks the size, followed by + %% a conversion to binary: + %% + %% _ = [if length(Comp) =:= 4; byte_size(Comp) =:= 4 -> [] end || + %% Comp <- Sof], + %% [align|iolist_to_binary(Sof)] + + CheckImm = [{'cond',[[{eq,{expr,"length("++mk_val(Var)++")"},Len}], + [{eq,{expr,"byte_size("++mk_val(Var)++")"},Len}]]}], + Al = case Align of + [] -> + []; + [align] -> + [{put_bits,0,0,[1|Align]}] + end, + case Al =:= [] orelse + is_end_aligned(LenImm) orelse + lb_is_nonzero(LenImm) of + false -> + %% Not possible because an empty SEQUENCE OF would be + %% improperly aligned. Example: + %% + %% SEQUENCE (SIZE (0..3)) OF ... + + Lc; + true -> + %% Examples: + %% + %% SEQUENCE (SIZE (1..4)) OF ... + %% (OK because there must be at least one element) + %% + %% SEQUENCE OF ... + %% (OK because the length field will force alignment) + %% + Al ++ [{lc,CheckImm,Var,Val,{var,"_"}}, + {call,erlang,iolist_to_binary,[Val]}] + end; +opt_lc([{lc,ElementImm0,V,L}]=Lc, LenImm) -> + %% Attempt to hoist the alignment, putting after the length + %% and before the list comprehension: + %% + %% [Length, + %% align, + %% [Encode(Comp) || Comp <- Sof]] + %% + + case enc_opt_al_1(ElementImm0, 0) of + {ElementImm,0} -> + case is_end_aligned(LenImm) orelse + (is_beginning_aligned(ElementImm0) andalso + lb_is_nonzero(LenImm)) of + false -> + %% Examples: + %% + %% SEQUENCE (SIZE (0..3)) OF OCTET STRING + %% (An empty SEQUENCE OF would be improperly aligned) + %% + %% SEQUENCE (SIZE (1..3)) OF OCTET STRING (SIZE (0..4)) + %% (There would be an improper alignment before the + %% first element) + + Lc; + true -> + %% Examples: + %% + %% SEQUENCE OF INTEGER + %% SEQUENCE (SIZE (1..4)) OF INTEGER + %% SEQUENCE (SIZE (1..4)) OF INTEGER (0..256) + + [{put_bits,0,0,[1,align]},{lc,ElementImm,V,L}] + end; + _ -> + %% Unknown alignment, no alignment, or not aligned at the end. + %% Examples: + %% + %% SEQUENCE OF SomeConstructedType + %% SEQUENCE OF INTEGER (0..15) + + Lc + end. + +is_beginning_aligned([{'cond',Cs}]) -> + lists:all(fun([_|Act]) -> is_beginning_aligned(Act) end, Cs); +is_beginning_aligned([{error,_}|_]) -> true; +is_beginning_aligned([{put_bits,_,_,U}|_]) -> + case U of + [_,align] -> true; + [_] -> false + end; +is_beginning_aligned(Imm0) -> + case split_off_nonbuilding(Imm0) of + {[],_} -> false; + {[_|_],Imm} -> is_beginning_aligned(Imm) + end. + +is_end_aligned(Imm) -> + case enc_opt_al_1(Imm, unknown) of + {_,0} -> true; + {_,_} -> false + end. + +lb_is_nonzero([{sub,_,_,_}|_]) -> true; +lb_is_nonzero(_) -> false. + +%%% +%%% Attempt to combine two chunks of intermediate code. +%%% + +combine_imms(ImmA0, ImmB0) -> + {Prefix0,ImmA} = split_off_nonbuilding(ImmA0), + {Prefix1,ImmB} = split_off_nonbuilding(ImmB0), + Prefix = Prefix0 ++ Prefix1, + Combined = do_combine(ImmA ++ ImmB, 3.0), + Prefix ++ Combined. + +do_combine([{error,_}=Imm|_], _Budget) -> + [Imm]; +do_combine([{'cond',Cs0}|T], Budget0) -> + Budget = debit(Budget0, num_clauses(Cs0, 0)), + Cs = [[C|do_combine(Act++T, Budget)] || [C|Act] <- Cs0], + [{'cond',Cs}]; +do_combine([{put_bits,V,_,_}|_]=L, Budget) when is_integer(V) -> + {Pb,T} = collect_put_bits(L), + do_combine_put_bits(Pb, T,Budget); +do_combine(_, _) -> + throw(impossible). + +do_combine_put_bits(Pb, [], _Budget) -> + Pb; +do_combine_put_bits(Pb, [{'cond',Cs0}|T], Budget) -> + Cs = [case Act of + [{error,_}] -> + [C|Act]; + _ -> + [C|do_combine(Pb++Act, Budget)] + end || [C|Act] <- Cs0], + do_combine([{'cond',Cs}|T], Budget); +do_combine_put_bits(_, _, _) -> + throw(impossible). + +debit(Budget0, Alternatives) -> + case Budget0 - log2(Alternatives) of + Budget when Budget > 0.0 -> + Budget; + _ -> + throw(impossible) + end. + +num_clauses([[_,{error,_}]|T], N) -> + num_clauses(T, N); +num_clauses([_|T], N) -> + num_clauses(T, N+1); +num_clauses([], N) -> N. + +log2(N) -> + math:log(N) / math:log(2.0). + +collect_put_bits(Imm) -> + lists:splitwith(fun({put_bits,V,_,_}) when is_integer(V) -> true; + (_) -> false + end, Imm). + +%%% +%%% Simple common subexpression elimination to avoid fetching +%%% the same element twice. +%%% + +enc_cse([{assign,{var,V},E}=H|T]) -> + [H|enc_cse_1(T, E, V)]; +enc_cse(Imm) -> Imm. + +enc_cse_1([{assign,Dst,E}|T], E, V) -> + [{assign,Dst,V}|enc_cse_1(T, E, V)]; +enc_cse_1([{block,Bl}|T], E, V) -> + [{block,enc_cse_1(Bl, E, V)}|enc_cse_1(T, E, V)]; +enc_cse_1([H|T], E, V) -> + [H|enc_cse_1(T, E, V)]; +enc_cse_1([], _, _) -> []. + + +%%% +%%% Pre-process the intermediate code to simplify code generation. +%%% + +enc_pre_cg(Imm) -> + enc_pre_cg_1(Imm, outside_list, in_seq). + +enc_pre_cg_1([], _StL, _StB) -> + nil; +enc_pre_cg_1([H], StL, StB) -> + enc_pre_cg_2(H, StL, StB); +enc_pre_cg_1([H0|T0], StL, StB) -> + case is_nonbuilding(H0) of + true -> + H = enc_pre_cg_nonbuilding(H0, StL), + Seq = {seq,H,enc_pre_cg_1(T0, StL, in_seq)}, + case StB of + outside_seq -> {block,Seq}; + in_seq -> Seq + end; + false -> + H = enc_pre_cg_2(H0, in_head, outside_seq), + T = enc_pre_cg_1(T0, in_tail, outside_seq), + enc_make_cons(H, T) + end. + +enc_pre_cg_2(align, StL, _StB) -> + case StL of + in_head -> align; + in_tail -> {cons,align,nil} + end; +enc_pre_cg_2({apply,_,_}=Imm, _, _) -> + Imm; +enc_pre_cg_2({block,Bl0}, StL, StB) -> + enc_pre_cg_1(Bl0, StL, StB); +enc_pre_cg_2({call,_,_,_}=Imm, _, _) -> + Imm; +enc_pre_cg_2({call_gen,_,_,_,_}=Imm, _, _) -> + Imm; +enc_pre_cg_2({'cond',Cs0}, StL, _StB) -> + Cs = [{C,enc_pre_cg_1(Act, StL, outside_seq)} || [C|Act] <- Cs0], + {'cond',Cs}; +enc_pre_cg_2({error,_}=E, _, _) -> + E; +enc_pre_cg_2({lc,B0,V,L}, StL, _StB) -> + B = enc_pre_cg_1(B0, StL, outside_seq), + {lc,B,V,L}; +enc_pre_cg_2({put_bits,V,8,[1]}, StL, _StB) -> + case StL of + in_head -> {integer,V}; + in_tail -> {cons,{integer,V},nil}; + outside_list -> {cons,{integer,V},nil} + end; +enc_pre_cg_2({put_bits,V,binary,_}, _StL, _StB) -> + V; +enc_pre_cg_2({put_bits,_,_,[_]}=PutBits, _StL, _StB) -> + {binary,[PutBits]}; +enc_pre_cg_2({var,_}=Imm, _, _) -> Imm. + +enc_make_cons({binary,H}, {binary,T}) -> + {binary,H++T}; +enc_make_cons({binary,H0}, {cons,{binary,H1},T}) -> + {cons,{binary,H0++H1},T}; +enc_make_cons({integer,Int}, {binary,T}) -> + {binary,[{put_bits,Int,8,[1]}|T]}; +enc_make_cons(H, T) -> + {cons,H,T}. + +enc_pre_cg_nonbuilding({'cond',Cs0,Dst}, StL) -> + Cs = [{C,enc_pre_cg_1(Act, StL, outside_seq)} || [C|Act] <- Cs0], + {'cond',Cs,Dst}; +enc_pre_cg_nonbuilding({lc,B0,Var,List,Dst}, StL) -> + B = enc_pre_cg_1(B0, StL, outside_seq), + {lc,B,Var,List,Dst}; +enc_pre_cg_nonbuilding({'try',Try0,{P,Succ0},Else0,Dst}, StL) -> + Try = enc_pre_cg_1(Try0, StL, outside_seq), + Succ = enc_pre_cg_1(Succ0, StL, outside_seq), + Else = enc_pre_cg_1(Else0, StL, outside_seq), + {'try',Try,{P,Succ},Else,Dst}; +enc_pre_cg_nonbuilding(Imm, _) -> Imm. + + +%%% +%%% Code generation for encoding. +%%% + +enc_cg({cons,_,_}=Cons) -> + enc_cg_cons(Cons); +enc_cg({block,Imm}) -> + emit(["begin",nl]), + enc_cg(Imm), + emit([nl, + "end"]); +enc_cg({seq,First,Then}) -> + enc_cg(First), + emit([com,nl]), + enc_cg(Then); +enc_cg(align) -> + emit(align); +enc_cg({apply,F0,As0}) -> + As = enc_call_args(As0, ""), + case F0 of + {M,F} -> + emit([{asis,M},":",{asis,F},"(",As,")"]); + F when is_atom(F) -> + emit([{asis,F},"(",As,")"]) + end; +enc_cg({apply,F0,As0,Dst}) -> + As = enc_call_args(As0, ""), + emit([mk_val(Dst)," = "]), + case F0 of + {M,F} -> + emit([{asis,M},":",{asis,F},"(",As,")"]); + F when is_atom(F) -> + emit([{asis,F},"(",As,")"]) + end; +enc_cg({assign,Dst0,Expr}) -> + Dst = mk_val(Dst0), + emit([Dst," = ",Expr]); +enc_cg({binary,PutBits}) -> + emit(["<<",enc_cg_put_bits(PutBits, ""),">>"]); +enc_cg({call,M,F,As0}) -> + As = [mk_val(A) || A <- As0], + asn1ct_func:call(M, F, As); +enc_cg({call,M,F,As0,Dst}) -> + As = [mk_val(A) || A <- As0], + emit([mk_val(Dst)," = "]), + asn1ct_func:call(M, F, As); +enc_cg({call_gen,Prefix,Key,Gen,As0}) -> + As = [mk_val(A) || A <- As0], + asn1ct_func:call_gen(Prefix, Key, Gen, As); +enc_cg({'cond',Cs}) -> + enc_cg_cond(Cs); +enc_cg({'cond',Cs,Dst0}) -> + Dst = mk_val(Dst0), + emit([Dst," = "]), + enc_cg_cond(Cs); +enc_cg({error,Error}) when is_function(Error, 0) -> + Error(); +enc_cg({error,Var0}) -> + Var = mk_val(Var0), + emit(["exit({error,{asn1,{illegal_value,",Var,"}}})"]); +enc_cg({integer,Int}) -> + emit(mk_val(Int)); +enc_cg({lc,Body,Var,List}) -> + emit("["), + enc_cg(Body), + emit([" || ",mk_val(Var)," <- ",mk_val(List),"]"]); +enc_cg({lc,Body,Var,List,Dst}) -> + emit([mk_val(Dst)," = ["]), + enc_cg(Body), + emit([" || ",mk_val(Var)," <- ",mk_val(List),"]"]); +enc_cg(nil) -> + emit("[]"); +enc_cg({sub,Src0,Int,Dst0}) -> + Src = mk_val(Src0), + Dst = mk_val(Dst0), + emit([Dst," = ",Src," - ",Int]); +enc_cg({'try',Try,{P,Succ},Else,Dst}) -> + emit([mk_val(Dst)," = try "]), + enc_cg(Try), + emit([" of",nl, + mk_val(P)," ->",nl]), + enc_cg(Succ), + emit([nl, + "catch throw:invalid ->",nl]), + enc_cg(Else), + emit([nl, + "end"]); +enc_cg({var,V}) -> + emit(V). + +enc_cg_cons(Cons) -> + emit("["), + enc_cg_cons_1(Cons), + emit("]"). + +enc_cg_cons_1({cons,H,{cons,_,_}=T}) -> + enc_cg(H), + emit([com,nl]), + enc_cg_cons_1(T); +enc_cg_cons_1({cons,H,nil}) -> + enc_cg(H); +enc_cg_cons_1({cons,H,T}) -> + enc_cg(H), + emit("|"), + enc_cg(T). + +enc_call_args([A|As], Sep) -> + [Sep,mk_val(A)|enc_call_args(As, ", ")]; +enc_call_args([], _) -> []. + +enc_cg_cond([{'_',Action}]) -> + enc_cg(Action); +enc_cg_cond(Cs) -> + emit("if "), + enc_cg_cond(Cs, ""), + emit([nl, + "end"]). + +enc_cg_cond([C|Cs], Sep) -> + emit(Sep), + enc_cg_cond_1(C), + enc_cg_cond(Cs, [";",nl]); +enc_cg_cond([], _) -> ok. + +enc_cg_cond_1({Cond,Action}) -> + enc_cond_term(Cond), + emit([" ->",nl]), + enc_cg(Action). + +enc_cond_term('_') -> + emit("true"); +enc_cond_term({ult,Var0,Int}) -> + Var = mk_val(Var0), + N = uper_num_bits(Int), + case 1 bsl N of + Int -> + emit([Var," bsr ",N," =:= 0"]); + _ -> + emit(["0 =< ",Var,", ",Var," < ",Int]) + end; +enc_cond_term({eq,Var0,Term}) -> + Var = mk_val(Var0), + emit([Var," =:= ",{asis,Term}]); +enc_cond_term({ge,Var0,Int}) -> + Var = mk_val(Var0), + emit([Var," >= ",Int]); +enc_cond_term({lt,Var0,Int}) -> + Var = mk_val(Var0), + emit([Var," < ",Int]). + +enc_cg_put_bits([{put_bits,Val0,N,[1]}|T], Sep) -> + Val = mk_val(Val0), + [[Sep,Val,":",integer_to_list(N)]|enc_cg_put_bits(T, ",")]; +enc_cg_put_bits([], _) -> []. + +mk_val({var,Str}) -> Str; +mk_val({expr,Str}) -> Str; +mk_val(Int) when is_integer(Int) -> integer_to_list(Int); +mk_val(Other) -> {asis,Other}. + +%%% +%%% Generate a function that maps a name of a bit position +%%% to the bit position. +%%% + +bit_string_name2pos_fun(NNL, Src) -> + {call_gen,"bit_string_name2pos_",NNL, + fun(Fd, Name) -> gen_name2pos(Fd, Name, NNL) end,[Src]}. + +gen_name2pos(Fd, Name, Names) -> + Cs0 = gen_name2pos_cs(Names, Name), + Cs = Cs0 ++ [bit_clause(Name),nil_clause(),invalid_clause()], + F = {function,1,Name,1,Cs}, + file:write(Fd, [erl_pp:function(F)]). + +gen_name2pos_cs([{K,V}|T], Name) -> + P = [{cons,0,{atom,0,K},{var,0,'T'}}], + B = [{cons,0,{integer,0,V},{call,0,{atom,0,Name},[{var,0,'T'}]}}], + [{clause,0,P,[],B}|gen_name2pos_cs(T, Name)]; +gen_name2pos_cs([], _) -> []. + +bit_clause(Name) -> + VarT = {var,0,'T'}, + VarPos = {var,0,'Pos'}, + P = [{cons,0,{tuple,0,[{atom,0,bit},VarPos]},VarT}], + G = [[{call,0,{atom,0,is_integer},[VarPos]}]], + B = [{cons,0,VarPos,{call,0,{atom,0,Name},[VarT]}}], + {clause,0,P,G,B}. + +nil_clause() -> + P = B = [{nil,0}], + {clause,0,P,[],B}. + +invalid_clause() -> + P = [{var,0,'_'}], + B = [{call,0,{atom,0,throw},[{atom,0,invalid}]}], + {clause,0,P,[],B}. + +%%% +%%% Hoist alignment to reduce the number of list elements in +%%% encode. Fewer lists elements means faster traversal in +%%% complete/{2,3}. +%%% +%%% For example, the following data sequence: +%%% +%%% [align,<<1:1,0:1>>,[align,<<Len:16>>|Data]] +%%% +%%% can be rewritten to: +%%% +%%% [align,<<1:1,0:1,0:6>>,[<<Len:16>>|Data]] +%%% +%%% The change from the literal <<1:1,0:1>> to <<1:1,0:1,0:6>> +%%% comes for free, and we have eliminated one element of the +%%% sub list. +%%% +%%% We must be careful not to rewrite: +%%% +%%% [<<1:1,0:1>>,[align,<<Len:16>>|Data]] +%%% +%%% to: +%%% +%%% [[<<1:1,0:1>>,align],[<<Len:16>>|Data]] +%%% +%%% because even though [<<1:0,0:1>>,align] is a literal and does +%%% not add any additional construction cost, there is one more +%%% sub list that needs to be traversed. +%%% + +enc_hoist_align(Imm0) -> + Imm = enc_hoist_align_reverse(Imm0, []), + enc_hoist_align(Imm, false, []). + +enc_hoist_align_reverse([H|T], Acc) -> + case enc_opt_al_1([H], 0) of + {[H],_} -> + enc_hoist_align_reverse(T, [H|Acc]); + {_,_} -> + lists:reverse(T, [H,stop|Acc]) + end; +enc_hoist_align_reverse([], Acc) -> Acc. + +enc_hoist_align([stop|T], _Aligned, Acc) -> + lists:reverse(T, Acc); +enc_hoist_align([{block,Bl0}|T], Aligned, Acc) -> + Bl = case Aligned of + false -> Bl0; + true -> enc_hoist_block(Bl0) + end, + case is_beginning_aligned(Bl) of + false -> + enc_hoist_align(T, false, [{block,Bl}|Acc]); + true -> + enc_hoist_align(T, true, [{put_bits,0,0,[1,align]}, + {block,Bl}|Acc]) + end; +enc_hoist_align([H|T], _, Acc) -> + enc_hoist_align(T, false, [H|Acc]); +enc_hoist_align([], _, Acc) -> Acc. + +enc_hoist_block(Bl) -> + try + enc_hoist_block_1(lists:reverse(Bl)) + catch + throw:impossible -> + Bl + end. + +enc_hoist_block_1([{'cond',Cs0}|T]) -> + Cs = [[C|enc_hoist_block_2(Act)] || [C|Act] <- Cs0], + H = {'cond',Cs}, + lists:reverse(T, [H]); +enc_hoist_block_1(_) -> + throw(impossible). + +enc_hoist_block_2([{'cond',_}|_]=L) -> + enc_hoist_block(L); +enc_hoist_block_2([{error,_}]=L) -> + L; +enc_hoist_block_2([]) -> + [{put_bits,0,0,[1,align]}]; +enc_hoist_block_2(L) -> + case lists:last(L) of + {put_bits,_,_,_} -> + L ++ [{put_bits,0,0,[1,align]}]; + _ -> + throw(impossible) + end. + +%%% +%%% Optimize alignment for encoding. +%%% + +enc_opt_al(Imm0) -> + {Imm,_} = enc_opt_al_1(Imm0, unknown), + Imm. + +enc_opt_al_1([{'cond',Cs0,Dst},{call,per,complete,[Dst],Bin}|T0], Al0) -> + {Cs1,{M,F}} = enc_opt_al_prepare_cond(Cs0), + {Cs,_} = enc_opt_al_cond(Cs1, 0), + {T,Al} = enc_opt_al_1([{call,M,F,[Dst],Bin}|T0], Al0), + {[{'cond',Cs,Dst}|T],Al}; +enc_opt_al_1([H0|T0], Al0) -> + {H,Al1} = enc_opt_al(H0, Al0), + {T,Al} = enc_opt_al_1(T0, Al1), + {H++T,Al}; +enc_opt_al_1([], Al) -> {[],Al}. + +enc_opt_al({apply,_,_,_}=Imm, Al) -> + {[Imm],Al}; +enc_opt_al({assign,_,_}=Imm, Al) -> + {[Imm],Al}; +enc_opt_al({block,Bl0}, Al0) -> + {Bl,Al} = enc_opt_al_1(Bl0, Al0), + {[{block,Bl}],Al}; +enc_opt_al({call,erlang,iolist_to_binary,[_]}=Imm, Al) -> + {[Imm],Al}; +enc_opt_al({call,per_common,encode_fragmented,[_,U]}=Call, Al) -> + case U rem 8 of + 0 -> {[Call],Al}; + _ -> {[Call],unknown} + end; +enc_opt_al({call,per_common,encode_unconstrained_number,[_]}=Call, _) -> + {[Call],0}; +enc_opt_al({call,_,_,_,_}=Call, Al) -> + {[Call],Al}; +enc_opt_al({'cond',Cs0}, Al0) -> + {Cs,Al} = enc_opt_al_cond(Cs0, Al0), + {[{'cond',Cs}],Al}; +enc_opt_al({error,_}=Imm, Al) -> + {[Imm],Al}; +enc_opt_al({put_bits,V,N,[U,align]}, Al0) when Al0 rem 8 =:= 0 -> + Al = if + is_integer(N) -> N*U; + N =:= binary, U rem 8 =:= 0 -> 0; + true -> unknown + end, + {[{put_bits,V,N,[U]}],Al}; +enc_opt_al({put_bits,V,binary,[U,align]}, Al0) when is_integer(Al0) -> + N = 8 - (Al0 rem 8), + Al = case U rem 8 of + 0 -> 0; + _ -> unknown + end, + {[{put_bits,0,N,[1]},{put_bits,V,binary,[U]}],Al}; +enc_opt_al({put_bits,V,N0,[U,align]}, Al0) when is_integer(N0), is_integer(Al0) -> + N = N0 + (8 - Al0 rem 8), + Al = N0*U, + {[{put_bits,V,N,[1]}],Al}; +enc_opt_al({put_bits,_,N,[U,align]}=PutBits, _) when is_integer(N) -> + {[PutBits],N*U}; +enc_opt_al({put_bits,_,binary,[U,align]}=PutBits, _) when U rem 8 =:= 0 -> + {[PutBits],0}; +enc_opt_al({put_bits,_,N,[U]}=PutBits, Al) when is_integer(N), is_integer(Al) -> + {[PutBits],Al+N*U}; +enc_opt_al({put_bits,_,binary,[U]}=PutBits, Al) when U rem 8 =:= 0 -> + {[PutBits],Al}; +enc_opt_al({sub,_,_,_}=Imm, Al) -> + {[Imm],Al}; +enc_opt_al(Imm, _) -> + {[Imm],unknown}. + +enc_opt_al_cond(Cs0, Al0) -> + enc_opt_al_cond_1(Cs0, Al0, [], []). + +enc_opt_al_cond_1([['_',{error,_}]=C|Cs], Al, CAcc, AAcc) -> + enc_opt_al_cond_1(Cs, Al, [C|CAcc], AAcc); +enc_opt_al_cond_1([[C|Act0]|Cs0], Al0, CAcc, AAcc) -> + {Act,Al1} = enc_opt_al_1(Act0, Al0), + Al = if + Al1 =:= unknown -> Al1; + true -> Al1 rem 8 + end, + enc_opt_al_cond_1(Cs0, Al0, [[C|Act]|CAcc], [Al|AAcc]); +enc_opt_al_cond_1([], _, CAcc, AAcc) -> + Al = case lists:usort(AAcc) of + [] -> unknown; + [Al0] -> Al0; + [_|_] -> unknown + end, + {lists:reverse(CAcc),Al}. + +enc_opt_al_prepare_cond(Cs0) -> + try enc_opt_al_prepare_cond_1(Cs0) of + Cs -> + {Cs,{erlang,iolist_to_binary}} + catch + throw:impossible -> + {Cs0,{per,complete}} + end. + +enc_opt_al_prepare_cond_1(Cs) -> + [[C|enc_opt_al_prepare_cond_2(Act)] || [C|Act] <- Cs]. + +enc_opt_al_prepare_cond_2([{put_bits,_,binary,[U|_]}|_]) when U rem 8 =/= 0 -> + throw(impossible); +enc_opt_al_prepare_cond_2([{put_bits,_,_,_}=H|T]) -> + [H|enc_opt_al_prepare_cond_2(T)]; +enc_opt_al_prepare_cond_2([{call,per_common,encode_fragmented,_}=H|T]) -> + [H|enc_opt_al_prepare_cond_2(T)]; +enc_opt_al_prepare_cond_2([_|_]) -> + throw(impossible); +enc_opt_al_prepare_cond_2([]) -> + [{put_bits,0,0,[1,align]}]. + + +%%% +%%% For the aligned PER format, fix up the intermediate format +%%% before code generation. Code generation will be somewhat +%%% easier if 'align' appear as a separate instruction. +%%% + +per_fixup([{apply,_,_}=H|T]) -> + [H|per_fixup(T)]; +per_fixup([{apply,_,_,_}=H|T]) -> + [H|per_fixup(T)]; +per_fixup([{block,Block}|T]) -> + [{block,per_fixup(Block)}|per_fixup(T)]; +per_fixup([{'assign',_,_}=H|T]) -> + [H|per_fixup(T)]; +per_fixup([{'cond',Cs0}|T]) -> + Cs = [[C|per_fixup(Act)] || [C|Act] <- Cs0], + [{'cond',Cs}|per_fixup(T)]; +per_fixup([{'cond',Cs0,Dst}|T]) -> + Cs = [[C|per_fixup(Act)] || [C|Act] <- Cs0], + [{'cond',Cs,Dst}|per_fixup(T)]; +per_fixup([{call,_,_,_}=H|T]) -> + [H|per_fixup(T)]; +per_fixup([{call,_,_,_,_}=H|T]) -> + [H|per_fixup(T)]; +per_fixup([{call_gen,_,_,_,_}=H|T]) -> + [H|per_fixup(T)]; +per_fixup([{error,_}=H|T]) -> + [H|per_fixup(T)]; +per_fixup([{lc,B,V,L}|T]) -> + [{lc,per_fixup(B),V,L}|per_fixup(T)]; +per_fixup([{lc,B,V,L,Dst}|T]) -> + [{lc,per_fixup(B),V,L,Dst}|per_fixup(T)]; +per_fixup([{sub,_,_,_}=H|T]) -> + [H|per_fixup(T)]; +per_fixup([{'try',Try0,{P,Succ0},Else0,Dst}|T]) -> + Try = per_fixup(Try0), + Succ = per_fixup(Succ0), + Else = per_fixup(Else0), + [{'try',Try,{P,Succ},Else,Dst}|per_fixup(T)]; +per_fixup([{put_bits,_,_,_}|_]=L) -> + fixup_put_bits(L); +per_fixup([{var,_}=H|T]) -> + [H|per_fixup(T)]; +per_fixup([]) -> []. + +fixup_put_bits([{put_bits,0,0,[_,align]}|T]) -> + [align|fixup_put_bits(T)]; +fixup_put_bits([{put_bits,0,0,_}|T]) -> + fixup_put_bits(T); +fixup_put_bits([{put_bits,V,N,[U,align]}|T]) -> + [align,{put_bits,V,N,[U]}|fixup_put_bits(T)]; +fixup_put_bits([{put_bits,_,_,_}=H|T]) -> + [H|fixup_put_bits(T)]; +fixup_put_bits(Other) -> per_fixup(Other). + %% effective_constraint(Type,C) %% Type = atom() %% C = [C1,...] diff --git a/lib/asn1/src/asn1ct_value.erl b/lib/asn1/src/asn1ct_value.erl index ecdfa3f645..992210232f 100644 --- a/lib/asn1/src/asn1ct_value.erl +++ b/lib/asn1/src/asn1ct_value.erl @@ -32,11 +32,11 @@ from_type(M,Typename) -> - case asn1_db:dbget(M,Typename) of - undefined -> + case asn1_db:dbload(M) of + error -> {error,{not_found,{M,Typename}}}; - Tdef when is_record(Tdef,typedef) -> - Type = Tdef#typedef.typespec, + ok -> + #typedef{typespec=Type} = asn1_db:dbget(M, Typename), from_type(M,[Typename],Type); Vdef when is_record(Vdef,valuedef) -> from_value(Vdef); diff --git a/lib/asn1/src/asn1rtt_ber.erl b/lib/asn1/src/asn1rtt_ber.erl index b5429fe324..583ff790b7 100644 --- a/lib/asn1/src/asn1rtt_ber.erl +++ b/lib/asn1/src/asn1rtt_ber.erl @@ -22,8 +22,7 @@ %% encoding / decoding of BER -export([ber_decode_nif/1,ber_decode_erlang/1,match_tags/2,ber_encode/1]). --export([encode_tags/2, - encode_tags/3, +-export([encode_tags/3, skip_ExtensionAdditions/2]). -export([encode_boolean/2,decode_boolean/2, encode_integer/2,encode_integer/3, diff --git a/lib/asn1/src/asn1rtt_per.erl b/lib/asn1/src/asn1rtt_per.erl index 9f4b7500d8..672c84593c 100644 --- a/lib/asn1/src/asn1rtt_per.erl +++ b/lib/asn1/src/asn1rtt_per.erl @@ -18,62 +18,7 @@ %% -module(asn1rtt_per). --export([setext/1, fixextensions/2, - skipextensions/3, - set_choice/3,encode_integer/2, - encode_small_number/1, - encode_constrained_number/2, - encode_length/1, - encode_length/2, - encode_bit_string/3, - encode_object_identifier/1, - encode_relative_oid/1, - complete/1, - encode_open_type/1, - encode_GeneralString/2, - encode_GraphicString/2, - encode_TeletexString/2, - encode_VideotexString/2, - encode_ObjectDescriptor/2, - encode_UTF8String/1, - encode_octet_string/2, - encode_known_multiplier_string/4, - octets_to_complete/2]). - --define('16K',16384). --define('32K',32768). --define('64K',65536). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% setext(true|false) -> CompleteList -%% - -setext(false) -> - [0]; -setext(true) -> - [1]. - -fixextensions({ext,ExtPos,ExtNum},Val) -> - case fixextensions(ExtPos,ExtNum+ExtPos,Val,0) of - 0 -> []; - ExtBits -> - [encode_small_length(ExtNum)|pre_complete_bits(ExtNum,ExtBits)] - end. - -fixextensions(Pos,MaxPos,_,Acc) when Pos >= MaxPos -> - Acc; -fixextensions(Pos,ExtPos,Val,Acc) -> - Bit = case catch(element(Pos+1,Val)) of - asn1_NOVALUE -> - 0; - asn1_NOEXTVALUE -> - 0; - {'EXIT',_} -> - 0; - _ -> - 1 - end, - fixextensions(Pos+1,ExtPos,Val,(Acc bsl 1)+Bit). +-export([skipextensions/3,complete/1]). skipextensions(Bytes0, Nr, ExtensionBitstr) when is_bitstring(ExtensionBitstr) -> Prev = Nr - 1, @@ -95,270 +40,6 @@ align(BitStr) when is_bitstring(BitStr) -> <<_:AlignBits,Rest/binary>> = BitStr, Rest. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% set_choice(Alt,Choices,Altnum) -> ListofBitSettings -%% Alt = atom() -%% Altnum = integer() | {integer(),integer()}% number of alternatives -%% Choices = [atom()] | {[atom()],[atom()]} -%% When Choices is a tuple the first list is the Rootset and the -%% second is the Extensions and then Altnum must also be a tuple with the -%% lengths of the 2 lists -%% -set_choice(Alt,{L1,L2},{Len1,_Len2}) -> - case set_choice_tag(Alt,L1) of - N when is_integer(N), Len1 > 1 -> - [0, % the value is in the root set - encode_constrained_number({0,Len1-1},N)]; - N when is_integer(N) -> - [0]; % no encoding if only 0 or 1 alternative - false -> - [1, % extension value - case set_choice_tag(Alt, L2) of - N2 when is_integer(N2) -> - encode_small_number(N2); - false -> - unknown_choice_alt - end] - end; -set_choice(Alt, L, Len) -> - case set_choice_tag(Alt, L) of - N when is_integer(N), Len > 1 -> - encode_constrained_number({0,Len-1},N); - N when is_integer(N) -> - []; % no encoding if only 0 or 1 alternative - false -> - [unknown_choice_alt] - end. - -set_choice_tag(Alt,Choices) -> - set_choice_tag(Alt,Choices,0). - -set_choice_tag(Alt,[Alt|_Rest],Tag) -> - Tag; -set_choice_tag(Alt,[_H|Rest],Tag) -> - set_choice_tag(Alt,Rest,Tag+1); -set_choice_tag(_Alt,[],_Tag) -> - false. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% encode_open_type(Constraint, Value) -> CompleteList -%% Value = list of bytes of an already encoded value (the list must be flat) -%% | binary -%% Contraint = not used in this version -%% -encode_open_type(Val) -> - case byte_size(Val) of - Size when Size > 255 -> - [encode_length(Size),21,<<Size:16>>,Val]; % octets implies align - Size -> - [encode_length(Size),20,Size,Val] - end. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% encode_integer(Constraint, Value) -> CompleteList -%% -encode_integer([{Rc,_Ec}],Val) when is_tuple(Rc) -> - try - [0|encode_integer([Rc], Val)] - catch - _:{error,{asn1,_}} -> - [1|encode_unconstrained_number(Val)] - end; -encode_integer([], Val) -> - encode_unconstrained_number(Val); -%% The constraint is the effective constraint, and in this case is a number -encode_integer([{'SingleValue',V}], V) -> - []; -encode_integer([{'ValueRange',{Lb,Ub}=VR,Range,PreEnc}],Val) - when Val >= Lb, Ub >= Val -> - %% this case when NamedNumberList - encode_constrained_number(VR, Range, PreEnc, Val); -encode_integer([{'ValueRange',{Lb,'MAX'}}], Val) when Lb =< Val -> - encode_semi_constrained_number(Lb, Val); -encode_integer([{'ValueRange',{'MIN',_}}], Val) -> - encode_unconstrained_number(Val); -encode_integer([{'ValueRange',VR={_Lb,_Ub}}], Val) -> - encode_constrained_number(VR, Val); -encode_integer(_,Val) -> - exit({error,{asn1,{illegal_value,Val}}}). - - -%% X.691:10.6 Encoding of a normally small non-negative whole number -%% Use this for encoding of CHOICE index if there is an extension marker in -%% the CHOICE -encode_small_number(Val) when Val < 64 -> - [10,7,Val]; -encode_small_number(Val) -> - [1|encode_semi_constrained_number(0, Val)]. - -%% X.691:10.7 Encoding of a semi-constrained whole number -encode_semi_constrained_number(Lb, Val) -> - Val2 = Val - Lb, - Oct = eint_positive(Val2), - Len = length(Oct), - if - Len < 128 -> - [20,Len+1,Len|Oct]; - Len < 256 -> - [encode_length(Len),20,Len|Oct]; - true -> - [encode_length(Len),21,<<Len:16>>|Oct] - end. - -encode_constrained_number({Lb,_Ub},_Range,{bits,N},Val) -> - Val2 = Val-Lb, - [10,N,Val2]; -encode_constrained_number({Lb,_Ub},_Range,{octets,N},Val) when N < 256-> - %% N is 8 or 16 (1 or 2 octets) - Val2 = Val-Lb, - [20,N,Val2]; -encode_constrained_number({Lb,_Ub},_Range,{octets,N},Val) -> % N>255 - %% N is 8 or 16 (1 or 2 octets) - Val2 = Val-Lb, - [21,<<N:16>>,Val2]; -encode_constrained_number({Lb,_Ub},Range,_,Val) -> - Val2 = Val-Lb, - if - Range =< 16#1000000 -> % max 3 octets - Octs = eint_positive(Val2), - L = length(Octs), - [encode_length({1,3},L),[20,L,Octs]]; - Range =< 16#100000000 -> % max 4 octets - Octs = eint_positive(Val2), - L = length(Octs), - [encode_length({1,4},L),[20,L,Octs]]; - Range =< 16#10000000000 -> % max 5 octets - Octs = eint_positive(Val2), - L = length(Octs), - [encode_length({1,5},L),[20,L,Octs]]; - true -> - exit({not_supported,{integer_range,Range}}) - end. - -encode_constrained_number({Lb,Ub}, Val) when Val >= Lb, Ub >= Val -> - Range = Ub - Lb + 1, - Val2 = Val - Lb, - if - Range == 1 -> []; - Range == 2 -> - [Val2]; - Range =< 4 -> - [10,2,Val2]; - Range =< 8 -> - [10,3,Val2]; - Range =< 16 -> - [10,4,Val2]; - Range =< 32 -> - [10,5,Val2]; - Range =< 64 -> - [10,6,Val2]; - Range =< 128 -> - [10,7,Val2]; - Range =< 255 -> - [10,8,Val2]; - Range =< 256 -> - [20,1,Val2]; - Range =< 65536 -> - [20,2,<<Val2:16>>]; - Range =< (1 bsl (255*8)) -> - Octs = binary:encode_unsigned(Val2), - RangeOcts = binary:encode_unsigned(Range - 1), - OctsLen = byte_size(Octs), - RangeOctsLen = byte_size(RangeOcts), - LengthBitsNeeded = minimum_bits(RangeOctsLen - 1), - [10,LengthBitsNeeded,OctsLen-1,20,OctsLen,Octs]; - true -> - exit({not_supported,{integer_range,Range}}) - end; -encode_constrained_number({_,_},Val) -> - exit({error,{asn1,{illegal_value,Val}}}). - -%% For some reason the minimum bits needed in the length field in -%% the encoding of constrained whole numbers must always be at least 2? -minimum_bits(N) when N < 4 -> 2; -minimum_bits(N) when N < 8 -> 3; -minimum_bits(N) when N < 16 -> 4; -minimum_bits(N) when N < 32 -> 5; -minimum_bits(N) when N < 64 -> 6; -minimum_bits(N) when N < 128 -> 7; -minimum_bits(_N) -> 8. - -%% X.691:10.8 Encoding of an unconstrained whole number - -encode_unconstrained_number(Val) -> - Oct = if - Val >= 0 -> - eint(Val, []); - true -> - enint(Val, []) - end, - Len = length(Oct), - if - Len < 128 -> - [20,Len + 1,Len|Oct]; - Len < 256 -> - [20,Len + 2,<<2:2,Len:14>>|Oct]; - true -> - [encode_length(Len),21,<<Len:16>>|Oct] - end. - -%% used for positive Values which don't need a sign bit -%% returns a list -eint_positive(Val) -> - case eint(Val,[]) of - [0,B1|T] -> - [B1|T]; - T -> - T - end. - - -eint(0, [B|Acc]) when B < 128 -> - [B|Acc]; -eint(N, Acc) -> - eint(N bsr 8, [N band 16#ff| Acc]). - -enint(-1, [B1|T]) when B1 > 127 -> - [B1|T]; -enint(N, Acc) -> - enint(N bsr 8, [N band 16#ff|Acc]). - -%% X.691:10.9 Encoding of a length determinant -%%encode_small_length(undefined,Len) -> % null means no UpperBound -%% encode_small_number(Len). - -%% X.691:10.9.3.5 -%% X.691:10.9.3.7 -encode_length(Len) -> % unconstrained - if - Len < 128 -> - [20,1,Len]; - Len < 16384 -> - <<20,2,2:2,Len:14>>; - true -> % should be able to endode length >= 16384 i.e. fragmented length - exit({error,{asn1,{encode_length,{nyi,above_16k}}}}) - end. - -encode_length({C,[]}, Len) -> - case C of - {Lb,Ub}=Vr when Lb =< Len, Len =< Ub -> - [0|encode_constrained_number(Vr, Len)]; - _ -> - [1|encode_length(Len)] - end; -encode_length(Len, Len) -> - []; -encode_length(Vr, Len) -> - encode_constrained_number(Vr, Len). - -%% X.691 10.9.3.4 (only used for length of bitmap that prefixes extension -%% additions in a sequence or set -encode_small_length(Len) when Len =< 64 -> - [10,7,Len-1]; -encode_small_length(Len) -> - [1,encode_length(Len)]. - - decode_length(Buffer) -> % un-constrained case align(Buffer) of <<0:1,Oct:7,Rest/binary>> -> @@ -370,511 +51,70 @@ decode_length(Buffer) -> % un-constrained exit({error,{asn1,{decode_length,{nyi,above_16k}}}}) end. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% bitstring NamedBitList -%% Val can be of: -%% - [identifiers] where only named identifers are set to one, -%% the Constraint must then have some information of the -%% bitlength. -%% - [list of ones and zeroes] all bits -%% - integer value representing the bitlist -%% C is constraint Len, only valid when identifiers - - -%% when the value is a list of {Unused,BinBits}, where -%% Unused = integer(), -%% BinBits = binary(). - -encode_bit_string(C, Bits, NamedBitList) when is_bitstring(Bits) -> - PadLen = (8 - (bit_size(Bits) band 7)) band 7, - Compact = {PadLen,<<Bits/bitstring,0:PadLen>>}, - encode_bin_bit_string(C, Compact, NamedBitList); -encode_bit_string(C, {Unused,BinBits}=Bin, NamedBitList) - when is_integer(Unused), is_binary(BinBits) -> - encode_bin_bit_string(C,Bin,NamedBitList); - -%% when the value is a list of named bits - -encode_bit_string(C, LoNB=[FirstVal | _RestVal], NamedBitList) when is_atom(FirstVal) -> - ToSetPos = get_all_bitposes(LoNB, NamedBitList, []), - BitList = make_and_set_list(ToSetPos,0), - encode_bit_string(C,BitList,NamedBitList);% consider the constraint - -encode_bit_string(C, BL=[{bit,_} | _RestVal], NamedBitList) -> - ToSetPos = get_all_bitposes(BL, NamedBitList, []), - BitList = make_and_set_list(ToSetPos,0), - encode_bit_string(C,BitList,NamedBitList); - -%% when the value is a list of ones and zeroes -encode_bit_string(Int, BitListValue, _) - when is_list(BitListValue),is_integer(Int),Int =< 16 -> - %% The type is constrained by a single value size constraint - %% range_check(Int,length(BitListValue)), - [40,Int,length(BitListValue),BitListValue]; -encode_bit_string(Int, BitListValue, _) - when is_list(BitListValue),is_integer(Int), Int =< 255 -> - %% The type is constrained by a single value size constraint - %% range_check(Int,length(BitListValue)), - [2,40,Int,length(BitListValue),BitListValue]; -encode_bit_string(Int, BitListValue, _) - when is_list(BitListValue),is_integer(Int), Int < ?'64K' -> - {Code,DesiredLength,Length} = - case length(BitListValue) of - B1 when B1 > Int -> - exit({error,{'BIT_STRING_length_greater_than_SIZE', - Int,BitListValue}}); - B1 when B1 =< 255,Int =< 255 -> - {40,Int,B1}; - B1 when B1 =< 255 -> - {42,<<Int:16>>,B1}; - B1 -> - {43,<<Int:16>>,<<B1:16>>} - end, - %% The type is constrained by a single value size constraint - [2,Code,DesiredLength,Length,BitListValue]; -encode_bit_string(no, BitListValue,[]) - when is_list(BitListValue) -> - [encode_length(length(BitListValue)), - 2|BitListValue]; -encode_bit_string({{Fix,Fix},Ext}, BitListValue,[]) - when is_integer(Fix), is_list(Ext) -> - case length(BitListValue) of - Len when Len =< Fix -> - [0|encode_bit_string(Fix, BitListValue, [])]; - _ -> - [1|encode_bit_string(no, BitListValue, [])] - end; -encode_bit_string(C, BitListValue,[]) - when is_list(BitListValue) -> - [encode_length(C, length(BitListValue)), - 2|BitListValue]; -encode_bit_string(no, BitListValue,_NamedBitList) - when is_list(BitListValue) -> - %% this case with an unconstrained BIT STRING can be made more efficient - %% if the complete driver can take a special code so the length field - %% is encoded there. - NewBitLVal = lists:reverse(lists:dropwhile(fun(0)->true;(1)->false end, - lists:reverse(BitListValue))), - [encode_length(length(NewBitLVal)),2|NewBitLVal]; -encode_bit_string({{Fix,Fix},Ext}, BitListValue, NamedBitList) - when is_integer(Fix), is_list(Ext) -> - case length(BitListValue) of - Len when Len =< Fix -> - [0|encode_bit_string(Fix, BitListValue, NamedBitList)]; - _ -> - [1|encode_bit_string(no, BitListValue, NamedBitList)] - end; -encode_bit_string(C, BitListValue, _NamedBitList) - when is_list(BitListValue) -> % C = {_,'MAX'} - NewBitLVal = bit_string_trailing_zeros(BitListValue, C), - [encode_length(C, length(NewBitLVal)),2|NewBitLVal]; - - -%% when the value is an integer -encode_bit_string(C, IntegerVal, NamedBitList) when is_integer(IntegerVal)-> - BitList = int_to_bitlist(IntegerVal), - encode_bit_string(C,BitList,NamedBitList). - -bit_string_trailing_zeros(BitList,C) when is_integer(C) -> - bit_string_trailing_zeros1(BitList,C,C); -bit_string_trailing_zeros(BitList,{Lb,Ub}) when is_integer(Lb) -> - bit_string_trailing_zeros1(BitList,Lb,Ub); -bit_string_trailing_zeros(BitList,{{Lb,Ub},_}) when is_integer(Lb) -> - bit_string_trailing_zeros1(BitList,Lb,Ub); -bit_string_trailing_zeros(BitList,_) -> - BitList. - -bit_string_trailing_zeros1(BitList,Lb,Ub) -> - case length(BitList) of - Lb -> BitList; - B when B < Lb -> BitList++lists:duplicate(Lb-B, 0); - D -> F = fun(L,LB,LB,_,_)->lists:reverse(L); - ([0|R],L1,LB,UB,Fun)->Fun(R,L1-1,LB,UB,Fun); - (L,L1,_,UB,_)when L1 =< UB -> lists:reverse(L); - (_,_L1,_,_,_) ->exit({error,{list_length_BIT_STRING, - BitList}}) end, - F(lists:reverse(BitList),D,Lb,Ub,F) - end. - -%% encode_bin_bit_string/3, when value is a tuple of Unused and BinBits. -%% Unused = integer(),i.e. number unused bits in least sign. byte of -%% BinBits = binary(). -encode_bin_bit_string(C, {Unused,BinBits}, _NamedBitList) - when is_integer(C),C=<16 -> - range_check(C, bit_size(BinBits) - Unused), - [45,C,byte_size(BinBits),BinBits]; -encode_bin_bit_string(C, {Unused,BinBits}, _NamedBitList) - when is_integer(C), C =< 255 -> - range_check(C, bit_size(BinBits) - Unused), - [2,45,C,byte_size(BinBits),BinBits]; -encode_bin_bit_string(C, {Unused,BinBits}, _NamedBitList) - when is_integer(C), C =< 65535 -> - range_check(C, bit_size(BinBits) - Unused), - case byte_size(BinBits) of - Size when Size =< 255 -> - [2,46,<<C:16>>,Size,BinBits]; - Size -> - [2,47,<<C:16>>,<<Size:16>>,BinBits] - end; -encode_bin_bit_string(C,UnusedAndBin={_,_},NamedBitList) -> - {Unused1,Bin1} = - %% removes all trailing bits if NamedBitList is not empty - remove_trailing_bin(NamedBitList,UnusedAndBin), - case C of - {Lb,Ub} when is_integer(Lb),is_integer(Ub) -> - Size = byte_size(Bin1), - [encode_length({Lb,Ub}, Size*8 - Unused1), - 2,octets_unused_to_complete(Unused1,Size,Bin1)]; - no -> - Size = byte_size(Bin1), - [encode_length(Size*8 - Unused1), - 2|octets_unused_to_complete(Unused1, Size, Bin1)]; - {{Fix,Fix},Ext} when is_integer(Fix),is_list(Ext) -> - case byte_size(Bin1)*8 - Unused1 of - Size when Size =< Fix -> - [0|encode_bin_bit_string(Fix,UnusedAndBin,NamedBitList)]; - _Size -> - [1|encode_bin_bit_string(no,UnusedAndBin,NamedBitList)] - end; - Sc -> - Size = byte_size(Bin1), - [encode_length(Sc, Size*8 - Unused1), - 2|octets_unused_to_complete(Unused1,Size,Bin1)] - end. - -range_check(C,C) when is_integer(C) -> - ok; -range_check(C1,C2) when is_integer(C1) -> - exit({error,{asn1,{bit_string_out_of_range,{C1,C2}}}}). - -remove_trailing_bin([], {Unused,Bin}) -> - {Unused,Bin}; -remove_trailing_bin(_NamedNumberList,{_Unused,<<>>}) -> - {0,<<>>}; -remove_trailing_bin(NamedNumberList, {_Unused,Bin}) -> - Size = byte_size(Bin)-1, - <<Bfront:Size/binary, LastByte:8>> = Bin, - %% clear the Unused bits to be sure - Unused1 = trailingZeroesInNibble(LastByte band 15), - Unused2 = - case Unused1 of - 4 -> - 4 + trailingZeroesInNibble(LastByte bsr 4); - _ -> Unused1 - end, - case Unused2 of - 8 -> - remove_trailing_bin(NamedNumberList,{0,Bfront}); - _ -> - {Unused2,Bin} - end. - - -trailingZeroesInNibble(0) -> - 4; -trailingZeroesInNibble(1) -> - 0; -trailingZeroesInNibble(2) -> - 1; -trailingZeroesInNibble(3) -> - 0; -trailingZeroesInNibble(4) -> - 2; -trailingZeroesInNibble(5) -> - 0; -trailingZeroesInNibble(6) -> - 1; -trailingZeroesInNibble(7) -> - 0; -trailingZeroesInNibble(8) -> - 3; -trailingZeroesInNibble(9) -> - 0; -trailingZeroesInNibble(10) -> - 1; -trailingZeroesInNibble(11) -> - 0; -trailingZeroesInNibble(12) -> %#1100 - 2; -trailingZeroesInNibble(13) -> - 0; -trailingZeroesInNibble(14) -> - 1; -trailingZeroesInNibble(15) -> - 0. - - -%%%%%%%%%%%%%%% -%% - -int_to_bitlist(Int) when is_integer(Int), Int > 0 -> - [Int band 1 | int_to_bitlist(Int bsr 1)]; -int_to_bitlist(0) -> - []. - - -%%%%%%%%%%%%%%%%%% -%% get_all_bitposes([list of named bits to set], named_bit_db, []) -> -%% [sorted_list_of_bitpositions_to_set] - -get_all_bitposes([{bit,ValPos}|Rest], NamedBitList, Ack) -> - get_all_bitposes(Rest, NamedBitList, [ValPos | Ack ]); - -get_all_bitposes([Val | Rest], NamedBitList, Ack) -> - case lists:keyfind(Val, 1, NamedBitList) of - {_ValName, ValPos} -> - get_all_bitposes(Rest, NamedBitList, [ValPos | Ack]); - false -> - exit({error,{asn1, {bitstring_namedbit, Val}}}) - end; -get_all_bitposes([], _NamedBitList, Ack) -> - lists:sort(Ack). - -%%%%%%%%%%%%%%%%%% -%% make_and_set_list([list of positions to set to 1])-> -%% returns list with all in SetPos set. -%% in positioning in list the first element is 0, the second 1 etc.., but -%% - -make_and_set_list([XPos|SetPos], XPos) -> - [1 | make_and_set_list(SetPos, XPos + 1)]; -make_and_set_list([Pos|SetPos], XPos) -> - [0 | make_and_set_list([Pos | SetPos], XPos + 1)]; -make_and_set_list([], _) -> - []. - - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% X.691:16 -%% encode_octet_string(Constraint, Val) -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -encode_octet_string({{Sv,Sv},Ext}=SZ, Val) when is_list(Ext), Sv =< 2 -> - Len = length(Val), - try - case encode_length(SZ, Len) of - [0|_]=EncLen -> - [EncLen,45,Sv*8,Sv,Val]; - [_|_]=EncLen -> - [EncLen|octets_to_complete(Len, Val)] - end - catch - exit:{error,{asn1,{encode_length,_}}} -> - encode_fragmented_octet_string(Val) - end; -encode_octet_string({_,_}=SZ, Val) -> - Len = length(Val), - try - [encode_length(SZ, Len),2|octets_to_complete(Len, Val)] - catch - exit:{error,{asn1,{encode_length,_}}} -> - encode_fragmented_octet_string(Val) - end; -encode_octet_string(Sv, Val) when is_integer(Sv) -> - encode_fragmented_octet_string(Val); -encode_octet_string(no, Val) -> - Len = length(Val), - try - [encode_length(Len),2|octets_to_complete(Len, Val)] - catch - exit:{error,{asn1,{encode_length,_}}} -> - encode_fragmented_octet_string(Val) - end. - -encode_fragmented_octet_string(Val) -> - Bin = iolist_to_binary(Val), - efos_1(Bin). - -efos_1(<<B1:16#C000/binary,B2:16#4000/binary,T/binary>>) -> - [20,1,<<3:2,4:6>>, - octets_to_complete(16#C000, B1), - octets_to_complete(16#4000, B2)|efos_1(T)]; -efos_1(<<B:16#C000/binary,T/binary>>) -> - [20,1,<<3:2,3:6>>,octets_to_complete(16#C000, B)|efos_1(T)]; -efos_1(<<B:16#8000/binary,T/binary>>) -> - [20,1,<<3:2,2:6>>,octets_to_complete(16#8000, B)|efos_1(T)]; -efos_1(<<B:16#4000/binary,T/binary>>) -> - [20,1,<<3:2,1:6>>,octets_to_complete(16#4000, B)|efos_1(T)]; -efos_1(<<>>) -> - [20,1,0]; -efos_1(<<B/bitstring>>) -> - Len = byte_size(B), - [encode_length(Len)|octets_to_complete(Len, B)]. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Restricted char string types -%% (NumericString, PrintableString,VisibleString,IA5String,BMPString,UniversalString) -%% X.691:26 and X.680:34-36 - -encode_restricted_string(Val) when is_list(Val)-> - Len = length(Val), - [encode_length(Len)|octets_to_complete(Len, Val)]. - -encode_known_multiplier_string(SizeC, NumBits, CharOutTab, Val) -> - Result = chars_encode2(Val, NumBits, CharOutTab), - case SizeC of - Ub when is_integer(Ub), Ub*NumBits < 16 -> - Result; - Ub when is_integer(Ub) -> - [2,Result]; - {{_,Ub},Ext}=SZ when is_list(Ext) -> - Len = length(Val), - case encode_length(SZ, Len) of - [0|_]=EncLen when Ub*NumBits < 16 -> - [EncLen,45,Len*NumBits,Len,Val]; - [_|_]=EncLen -> - [EncLen,2|Result] - end; - {_,Ub}=Range -> - [encode_length(Range, length(Val))| - if - Ub*NumBits < 16 -> Result; - true -> [2|Result] - end]; - no -> - [encode_length(length(Val)),2,Result] - end. - -encode_GeneralString(_C,Val) -> - encode_restricted_string(Val). - -encode_GraphicString(_C,Val) -> - encode_restricted_string(Val). - -encode_ObjectDescriptor(_C,Val) -> - encode_restricted_string(Val). - -encode_TeletexString(_C,Val) -> % equivalent with T61String - encode_restricted_string(Val). - -encode_VideotexString(_C,Val) -> - encode_restricted_string(Val). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% chars_encode(C,StringType,Value) -> ValueList -%% -%% encodes chars according to the per rules taking the constraint -%% PermittedAlphabet into account. -%% -%% This function only encodes the value part and NOT the length. - -chars_encode2([H|T],NumBits,T1={Min,Max,notab}) when H =< Max, H >= Min -> - [pre_complete_bits(NumBits,H-Min)|chars_encode2(T,NumBits,T1)]; -chars_encode2([H|T],NumBits,T1={Min,Max,Tab}) when H =< Max, H >= Min -> - [pre_complete_bits(NumBits,exit_if_false(H,element(H-Min+1,Tab)))| - chars_encode2(T,NumBits,T1)]; -chars_encode2([{A,B,C,D}|T],NumBits,T1={Min,_Max,notab}) -> - %% no value range check here (ought to be, but very expensive) - [pre_complete_bits(NumBits, - ((((((A bsl 8)+B) bsl 8)+C) bsl 8)+D)-Min)| - chars_encode2(T,NumBits,T1)]; -chars_encode2([H={A,B,C,D}|T],NumBits,{Min,Max,Tab}) -> - %% no value range check here (ought to be, but very expensive) - [pre_complete_bits(NumBits,exit_if_false(H,element(((((((A bsl 8)+B) bsl 8)+C) bsl 8)+D)-Min,Tab)))|chars_encode2(T,NumBits,{Min,Max,notab})]; -chars_encode2([H|_T],_NumBits,{_Min,_Max,_Tab}) -> - exit({error,{asn1,{illegal_char_value,H}}}); -chars_encode2([],_,_) -> - []. - -exit_if_false(V,false)-> - exit({error,{asn1,{"illegal value according to Permitted alphabet constraint",V}}}); -exit_if_false(_,V) ->V. - -pre_complete_bits(NumBits,Val) when NumBits =< 8 -> - [10,NumBits,Val]; -pre_complete_bits(NumBits,Val) when NumBits =< 16 -> - [10,NumBits-8,Val bsr 8,10,8,(Val band 255)]; -pre_complete_bits(NumBits,Val) when NumBits =< 2040 -> % 255 * 8 - Unused = (8 - (NumBits rem 8)) rem 8, - Len = NumBits + Unused, - [30,Unused,Len div 8,<<(Val bsl Unused):Len>>]. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% encode_UTF8String(Val) -> CompleteList -%% Val -> <<utf8encoded binary>> -%% CompleteList -> [apropriate codes and values for driver complete] -%% -encode_UTF8String(Val) when is_binary(Val) -> - Sz = byte_size(Val), - [encode_length(Sz),octets_to_complete(Sz, Val)]; -encode_UTF8String(Val) -> - encode_UTF8String(list_to_binary(Val)). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% encode_object_identifier(Val) -> CompleteList -%% encode_object_identifier({Name,Val}) -> CompleteList -%% Val -> {Int1,Int2,...,IntN} % N >= 2 -%% Name -> atom() -%% Int1 -> integer(0..2) -%% Int2 -> integer(0..39) when Int1 (0..1) else integer() -%% Int3-N -> integer() -%% CompleteList -> [{bits,8,Val}|{octets,Ol}|align|...] -%% -encode_object_identifier(Val) -> - OctetList = e_object_identifier(Val), - Octets = list_to_binary(OctetList), - Sz = byte_size(Octets), - [encode_length(Sz), - octets_to_complete(Sz, Octets)]. - -e_object_identifier({'OBJECT IDENTIFIER',V}) -> - e_object_identifier(V); -e_object_identifier(V) when is_tuple(V) -> - e_object_identifier(tuple_to_list(V)); - -%% E1 = 0|1|2 and (E2 < 40 when E1 = 0|1) -e_object_identifier([E1,E2|Tail]) when E1 >= 0, E1 < 2, E2 < 40 ; E1==2 -> - Head = 40*E1 + E2, % weird - e_object_elements([Head|Tail],[]); -e_object_identifier(Oid=[_,_|_Tail]) -> - exit({error,{asn1,{'illegal_value',Oid}}}). - -e_object_elements([],Acc) -> - lists:reverse(Acc); -e_object_elements([H|T],Acc) -> - e_object_elements(T,[e_object_element(H)|Acc]). - -e_object_element(Num) when Num < 128 -> - [Num]; -e_object_element(Num) -> - [e_o_e(Num bsr 7)|[Num band 2#1111111]]. -e_o_e(Num) when Num < 128 -> - Num bor 2#10000000; -e_o_e(Num) -> - [e_o_e(Num bsr 7)|[(Num band 2#1111111) bor 2#10000000]]. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% encode_relative_oid(Val) -> CompleteList -%% encode_relative_oid({Name,Val}) -> CompleteList -encode_relative_oid(Val) when is_tuple(Val) -> - encode_relative_oid(tuple_to_list(Val)); -encode_relative_oid(Val) when is_list(Val) -> - Octets = list_to_binary([e_object_element(X)||X <- Val]), - Sz = byte_size(Octets), - [encode_length(Sz)|octets_to_complete(Sz, Octets)]. - %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% complete(InList) -> ByteList %% Takes a coded list with bits and bytes and converts it to a list of bytes %% Should be applied as the last step at encode of a complete ASN.1 type %% -complete(L) -> - case asn1rt_nif:encode_per_complete(L) of +complete(L0) -> + L = complete(L0, []), + case list_to_bitstring(L) of <<>> -> <<0>>; Bin -> Bin end. -octets_to_complete(Len,Val) when Len < 256 -> - [20,Len,Val]; -octets_to_complete(Len,Val) -> - [21,<<Len:16>>,Val]. - -octets_unused_to_complete(Unused,Len,Val) when Len < 256 -> - [30,Unused,Len,Val]; -octets_unused_to_complete(Unused,Len,Val) -> - [31,Unused,<<Len:16>>,Val]. +complete([], []) -> + []; +complete([], [H|More]) -> + complete(H, More); +complete([align|T], More) -> + complete(T, More); +complete([[]|T], More) -> + complete(T, More); +complete([[_|_]=H], More) -> + complete(H, More); +complete([[_|_]=H|T], More) -> + complete(H, [T|More]); +complete([H|T], More) when is_integer(H); is_binary(H) -> + [H|complete(T, More)]; +complete([H|T], More) -> + [H|complete(T, bit_size(H), More)]; +complete(Bin, More) when is_binary(Bin) -> + [Bin|complete([], More)]; +complete(Bin, More) -> + [Bin|complete([], bit_size(Bin), More)]. + +complete([], Bits, []) -> + case Bits band 7 of + 0 -> []; + N -> [<<0:(8-N)>>] + end; +complete([], Bits, [H|More]) -> + complete(H, Bits, More); +complete([align|T], Bits, More) -> + case Bits band 7 of + 0 -> complete(T, More); + 1 -> [<<0:7>>|complete(T, More)]; + 2 -> [<<0:6>>|complete(T, More)]; + 3 -> [<<0:5>>|complete(T, More)]; + 4 -> [<<0:4>>|complete(T, More)]; + 5 -> [<<0:3>>|complete(T, More)]; + 6 -> [<<0:2>>|complete(T, More)]; + 7 -> [<<0:1>>|complete(T, More)] + end; +complete([[]|T], Bits, More) -> + complete(T, Bits, More); +complete([[_|_]=H], Bits, More) -> + complete(H, Bits, More); +complete([[_|_]=H|T], Bits, More) -> + complete(H, Bits, [T|More]); +complete([H|T], Bits, More) when is_integer(H); + is_binary(H) -> + [H|complete(T, Bits, More)]; +complete([H|T], Bits, More) -> + [H|complete(T, Bits+bit_size(H), More)]; +complete(Bin, Bits, More) when is_binary(Bin) -> + [Bin|complete([], Bits, More)]; +complete(Bin, Bits, More) -> + [Bin|complete([], Bits+bit_size(Bin), More)]. diff --git a/lib/asn1/src/asn1rtt_per_common.erl b/lib/asn1/src/asn1rtt_per_common.erl index e7edc2b65f..9e9fd87ec3 100644 --- a/lib/asn1/src/asn1rtt_per_common.erl +++ b/lib/asn1/src/asn1rtt_per_common.erl @@ -28,7 +28,16 @@ decode_chars/2,decode_chars/3, decode_chars_16bit/1, decode_big_chars/2, - decode_oid/1,decode_relative_oid/1]). + decode_oid/1,decode_relative_oid/1, + encode_chars/2,encode_chars/3, + encode_chars_16bit/1,encode_big_chars/1, + encode_fragmented/2, + encode_oid/1,encode_relative_oid/1, + encode_unconstrained_number/1, + bitstring_from_positions/1,bitstring_from_positions/2, + to_bitstring/1,to_bitstring/2, + to_named_bitstring/1,to_named_bitstring/2, + extension_bitmap/3]). -define('16K',16384). @@ -90,6 +99,182 @@ decode_oid(Octets) -> decode_relative_oid(Octets) -> list_to_tuple(dec_subidentifiers(Octets, 0, [])). +encode_chars(Val, NumBits) -> + << <<C:NumBits>> || C <- Val >>. + +encode_chars(Val, NumBits, {Lb,Tab}) -> + << <<(enc_char(C, Lb, Tab)):NumBits>> || C <- Val >>. + +encode_chars_16bit(Val) -> + L = [case C of + {0,0,A,B} -> [A,B]; + C when is_integer(C) -> [0,C] + end || C <- Val], + iolist_to_binary(L). + +encode_big_chars(Val) -> + L = [case C of + {_,_,_,_} -> tuple_to_list(C); + C when is_integer(C) -> [<<0,0,0>>,C] + end || C <- Val], + iolist_to_binary(L). + +encode_fragmented(Bin, Unit) -> + encode_fragmented_1(Bin, Unit, 4). + +encode_oid(Val) when is_tuple(Val) -> + encode_oid(tuple_to_list(Val)); +encode_oid(Val) -> + iolist_to_binary(e_object_identifier(Val)). + +encode_relative_oid(Val) when is_tuple(Val) -> + encode_relative_oid(tuple_to_list(Val)); +encode_relative_oid(Val) when is_list(Val) -> + list_to_binary([e_object_element(X)||X <- Val]). + +encode_unconstrained_number(Val) when Val >= 0 -> + if + Val < 16#80 -> + [1,Val]; + Val < 16#100 -> + [<<2,0>>,Val]; + true -> + case binary:encode_unsigned(Val) of + <<0:1,_/bitstring>>=Bin -> + case byte_size(Bin) of + Sz when Sz < 128 -> + [Sz,Bin]; + Sz when Sz < 16384 -> + [<<2:2,Sz:14>>,Bin] + end; + <<1:1,_/bitstring>>=Bin -> + case byte_size(Bin)+1 of + Sz when Sz < 128 -> + [Sz,0,Bin]; + Sz when Sz < 16384 -> + [<<2:2,Sz:14,0:8>>,Bin] + end + end + end; +encode_unconstrained_number(Val) -> + Oct = enint(Val, []), + Len = length(Oct), + if + Len < 128 -> + [Len|Oct]; + Len < 16384 -> + [<<2:2,Len:14>>|Oct] + end. + +%% bitstring_from_positions([Position]) -> BitString +%% Given an unsorted list of bit positions (0..MAX), construct +%% a BIT STRING. The rightmost bit will always be a one. + +bitstring_from_positions([]) -> <<>>; +bitstring_from_positions([_|_]=L0) -> + L1 = lists:sort(L0), + L = diff(L1, -1), + << <<1:(N+0)>> || N <- L >>. + +%% bitstring_from_positions([Position], Lb) -> BitString +%% Given an unsorted list of bit positions (0..MAX) and a lower bound +%% for the number of bits, construct BIT STRING (zero-padded on the +%% right side if needed). + +bitstring_from_positions(L0, Lb) -> + L1 = lists:sort(L0), + L = diff(L1, -1, Lb-1), + << <<B:(N+0)>> || {B,N} <- L >>. + +%% to_bitstring(Val) -> BitString +%% Val = BitString | {Unused,Binary} | [OneOrZero] | Integer +%% Given one of the possible representations for a BIT STRING, +%% return a bitstring (without adding or removing any zero bits +%% at the right end). + +to_bitstring({0,Bs}) when is_binary(Bs) -> + Bs; +to_bitstring({Unused,Bs0}) when is_binary(Bs0) -> + Sz = bit_size(Bs0) - Unused, + <<Bs:Sz/bits,_/bits>> = Bs0, + Bs; +to_bitstring(Bs) when is_bitstring(Bs) -> + Bs; +to_bitstring(Int) when is_integer(Int), Int >= 0 -> + L = int_to_bitlist(Int), + << <<B:1>> || B <- L >>; +to_bitstring(L) when is_list(L) -> + << <<B:1>> || B <- L >>. + +%% to_bitstring(Val, Lb) -> BitString +%% Val = BitString | {Unused,Binary} | [OneOrZero] | Integer +%% Lb = Integer +%% Given one of the possible representations for a BIT STRING +%% and the lower bound for the number of bits, +%% return a bitstring at least Lb bits long (padded with zeroes +%% if needed). + +to_bitstring({0,Bs}, Lb) when is_binary(Bs) -> + case bit_size(Bs) of + Sz when Sz < Lb -> + <<Bs/bits,0:(Lb-Sz)>>; + _ -> + Bs + end; +to_bitstring({Unused,Bs0}, Lb) when is_binary(Bs0) -> + Sz = bit_size(Bs0) - Unused, + if + Sz < Lb -> + <<Bs0:Sz/bits,0:(Lb-Sz)>>; + true -> + <<Bs:Sz/bits,_/bits>> = Bs0, + Bs + end; +to_bitstring(Bs, Lb) when is_bitstring(Bs) -> + adjust_size(Bs, Lb); +to_bitstring(Int, Lb) when is_integer(Int), Int >= 0 -> + L = int_to_bitlist(Int), + Bs = << <<B:1>> || B <- L >>, + adjust_size(Bs, Lb); +to_bitstring(L, Lb) when is_list(L) -> + Bs = << <<B:1>> || B <- L >>, + adjust_size(Bs, Lb). + +%% to_named_bitstring(Val) -> BitString +%% Val = BitString | {Unused,Binary} | [OneOrZero] | Integer +%% Given one of the possible representations for a BIT STRING, +%% return a bitstring where any trailing zeroes have been stripped. + +to_named_bitstring(Val) -> + Bs = to_bitstring(Val), + bs_drop_trailing_zeroes(Bs). + +%% to_named_bitstring(Val, Lb) -> BitString +%% Val = BitString | {Unused,Binary} | [OneOrZero] | Integer +%% Lb = Integer +%% Given one of the possible representations for a BIT STRING +%% and the lower bound for the number of bits, +%% return a bitstring that is at least Lb bits long. There will +%% be zeroes at the right only if needed to reach the lower bound +%% for the number of bits. + +to_named_bitstring({0,Bs}, Lb) when is_binary(Bs) -> + adjust_trailing_zeroes(Bs, Lb); +to_named_bitstring({Unused,Bs0}, Lb) when is_binary(Bs0) -> + Sz = bit_size(Bs0) - Unused, + <<Bs:Sz/bits,_/bits>> = Bs0, + adjust_trailing_zeroes(Bs, Lb); +to_named_bitstring(Bs, Lb) when is_bitstring(Bs) -> + adjust_trailing_zeroes(Bs, Lb); +to_named_bitstring(Val, Lb) -> + %% Obsolete representations: list or integer. Optimize + %% for correctness, not speed. + adjust_trailing_zeroes(to_bitstring(Val), Lb). + + +extension_bitmap(Val, Pos, Limit) -> + extension_bitmap(Val, Pos, Limit, 0). + %%% %%% Internal functions. %%% @@ -124,3 +309,149 @@ dec_subidentifiers([H|T], Av, Al) -> dec_subidentifiers(T, 0, [(Av bsl 7) bor H|Al]); dec_subidentifiers([], _Av, Al) -> lists:reverse(Al). + +enc_char(C0, Lb, Tab) -> + try element(C0-Lb, Tab) of + ill -> + illegal_char_error(); + C -> + C + catch + error:badarg -> + illegal_char_error() + end. + +illegal_char_error() -> + error({error,{asn1,"value forbidden by FROM constraint"}}). + +encode_fragmented_1(Bin, Unit, N) -> + SegSz = Unit * N * ?'16K', + case Bin of + <<B:SegSz/bitstring,T/bitstring>> -> + [<<3:2,N:6>>,B|encode_fragmented_1(T, Unit, N)]; + _ when N > 1 -> + encode_fragmented_1(Bin, Unit, N-1); + _ -> + case bit_size(Bin) div Unit of + Len when Len < 128 -> + [Len,Bin]; + Len when Len < 16384 -> + [<<2:2,Len:14>>,Bin] + end + end. + +%% E1 = 0|1|2 and (E2 < 40 when E1 = 0|1) +e_object_identifier([E1,E2|Tail]) when E1 >= 0, E1 < 2, E2 < 40; E1 =:= 2 -> + Head = 40*E1 + E2, + e_object_elements([Head|Tail], []); +e_object_identifier([_,_|_Tail]=Oid) -> + exit({error,{asn1,{'illegal_value',Oid}}}). + +e_object_elements([], Acc) -> + lists:reverse(Acc); +e_object_elements([H|T], Acc) -> + e_object_elements(T, [e_object_element(H)|Acc]). + +e_object_element(Num) when Num < 128 -> + [Num]; +e_object_element(Num) -> + [e_o_e(Num bsr 7)|[Num band 2#1111111]]. + +e_o_e(Num) when Num < 128 -> + Num bor 2#10000000; +e_o_e(Num) -> + [e_o_e(Num bsr 7)|[(Num band 2#1111111) bor 2#10000000]]. + +enint(-1, [B1|T]) when B1 > 127 -> + [B1|T]; +enint(N, Acc) -> + enint(N bsr 8, [N band 16#ff|Acc]). + +diff([H|T], Prev) -> + [H-Prev|diff(T, H)]; +diff([], _) -> []. + +diff([H|T], Prev, Last) -> + [{1,H-Prev}|diff(T, H, Last)]; +diff([], Prev, Last) when Last >= Prev -> + [{0,Last-Prev}]; +diff([], _, _) -> []. + +int_to_bitlist(0) -> []; +int_to_bitlist(Int) -> [Int band 1|int_to_bitlist(Int bsr 1)]. + +adjust_size(Bs, Lb) -> + case bit_size(Bs) of + Sz when Sz < Lb -> + <<Bs:Sz/bits,0:(Lb-Sz)>>; + _ -> + Bs + end. + +adjust_trailing_zeroes(Bs0, Lb) -> + case bit_size(Bs0) of + Sz when Sz < Lb -> + %% Too short - pad with zeroes. + <<Bs0:Sz/bits,0:(Lb-Sz)>>; + Lb -> + %% Exactly the right size - nothing to do. + Bs0; + _ -> + %% Longer than the lower bound - drop trailing zeroes. + <<_:Lb/bits,Tail/bits>> = Bs0, + Sz = Lb + bit_size(bs_drop_trailing_zeroes(Tail)), + <<Bs:Sz/bits,_/bits>> = Bs0, + Bs + end. + +bs_drop_trailing_zeroes(Bs) -> + bs_drop_trailing_zeroes(Bs, bit_size(Bs)). + +bs_drop_trailing_zeroes(Bs0, Sz0) when Sz0 < 8 -> + <<Byte:Sz0>> = Bs0, + Sz = Sz0 - ntz(Byte), + <<Bs:Sz/bits,_/bits>> = Bs0, + Bs; +bs_drop_trailing_zeroes(Bs0, Sz0) -> + Sz1 = Sz0 - 8, + <<Bs1:Sz1/bits,Byte:8>> = Bs0, + case ntz(Byte) of + 8 -> + bs_drop_trailing_zeroes(Bs1, Sz1); + Ntz -> + Sz = Sz0 - Ntz, + <<Bs:Sz/bits,_:Ntz/bits>> = Bs0, + Bs + end. + +%% ntz(Byte) -> Number of trailing zeroes. +ntz(Byte) -> + %% The table was calculated like this: + %% NTZ = fun (B, N, NTZ) when B band 1 =:= 0 -> NTZ(B bsr 1, N+1, NTZ); (_, N, _) -> N end. + %% io:format("~w\n", [list_to_tuple([NTZ(B+256, 0, NTZ) || B <- lists:seq(0, 255)])]). + T = {8,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0, + 4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0, + 5,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0, + 4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0, + 6,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0, + 4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0, + 5,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0, + 4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0, + 7,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0, + 4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0, + 5,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0, + 4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0, + 6,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0, + 4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0, + 5,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0, + 4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0}, + element(Byte+1, T). + +extension_bitmap(_Val, Pos, Limit, Acc) when Pos >= Limit -> + Acc; +extension_bitmap(Val, Pos, Limit, Acc) -> + Bit = case element(Pos, Val) of + asn1_NOVALUE -> 0; + _ -> 1 + end, + extension_bitmap(Val, Pos+1, Limit, (Acc bsl 1) bor Bit). diff --git a/lib/asn1/src/asn1rtt_real_common.erl b/lib/asn1/src/asn1rtt_real_common.erl index 22a1f4c4dd..12ca165ecd 100644 --- a/lib/asn1/src/asn1rtt_real_common.erl +++ b/lib/asn1/src/asn1rtt_real_common.erl @@ -105,8 +105,7 @@ encode_real(_C, {Mantissa, Base, Exponent}) when Base =:= 2 -> true -> list_to_binary(real_mininum_octets(-(Man))) % signbit keeps track of sign end, %% ok = io:format("LenMask: ~w EOctets: ~w~nFirstOctet: ~w OctMantissa: ~w OctExpLen: ~w~n", [LenMask, EOctets, FirstOctet, OctMantissa, OctExpLen]), - Bin = <<FirstOctet/binary, EOctets/binary, OctMantissa/binary>>, - {Bin, size(Bin)}; + <<FirstOctet/binary, EOctets/binary, OctMantissa/binary>>; encode_real(C, {Mantissa,Base,Exponent}) when Base =:= 10, is_integer(Mantissa), is_integer(Exponent) -> %% always encode as NR3 due to DER on the format @@ -176,8 +175,7 @@ encode_real_as_string(_C, Mantissa, Exponent) end, ManBin = list_to_binary(TruncMant), NR3 = 3, - {<<NR3,ManBin/binary,$.,ExpBin/binary>>, - 2 + byte_size(ManBin) + byte_size(ExpBin)}. + <<NR3,ManBin/binary,$.,ExpBin/binary>>. remove_trailing_zeros(IntStr) -> case lists:dropwhile(fun($0)-> true; diff --git a/lib/asn1/src/asn1rtt_uper.erl b/lib/asn1/src/asn1rtt_uper.erl index a5035c6660..68a89c70e1 100644 --- a/lib/asn1/src/asn1rtt_uper.erl +++ b/lib/asn1/src/asn1rtt_uper.erl @@ -19,95 +19,8 @@ %% -module(asn1rtt_uper). --export([setext/1, fixoptionals/3, - fixextensions/2, - skipextensions/3]). --export([set_choice/3, encode_integer/2, encode_integer/3]). --export([encode_small_number/1, encode_constrained_number/2, - encode_boolean/1, - encode_length/1, encode_length/2, - encode_bit_string/3]). --export([encode_octet_string/1,encode_octet_string/2, - encode_relative_oid/1, - encode_object_identifier/1, - complete/1, complete_NFP/1]). - - -export([encode_open_type/1]). - - -export([encode_UniversalString/3, - encode_PrintableString/3, - encode_GeneralString/2, - encode_GraphicString/2, - encode_TeletexString/2, - encode_VideotexString/2, - encode_VisibleString/3, - encode_UTF8String/1, - encode_BMPString/3, - encode_IA5String/3, - encode_NumericString/3, - encode_ObjectDescriptor/2 - ]). - --define('16K',16384). --define('32K',32768). --define('64K',65536). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% setext(true|false) -> CompleteList -%% - -setext(false) -> - <<0:1>>; -setext(true) -> - <<1:1>>. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% This is the new fixoptionals/3 which is used by the new generates -%% -fixoptionals(OptList,OptLength,Val) when is_tuple(Val) -> - Bits = fixoptionals(OptList,Val,0), - {Val,<<Bits:OptLength>>}; - -fixoptionals([],_Val,Acc) -> - %% Optbits - Acc; -fixoptionals([{Pos,DefVal}|Ot],Val,Acc) -> - case element(Pos,Val) of - asn1_DEFAULT -> fixoptionals(Ot,Val,Acc bsl 1); - DefVal -> fixoptionals(Ot,Val,Acc bsl 1); - _ -> fixoptionals(Ot,Val,(Acc bsl 1) + 1) - end; -fixoptionals([Pos|Ot],Val,Acc) -> - case element(Pos,Val) of - asn1_NOVALUE -> fixoptionals(Ot,Val,Acc bsl 1); - asn1_DEFAULT -> fixoptionals(Ot,Val,Acc bsl 1); - _ -> fixoptionals(Ot,Val,(Acc bsl 1) + 1) - end. - - -fixextensions({ext,ExtPos,ExtNum},Val) -> - case fixextensions(ExtPos,ExtNum+ExtPos,Val,0) of - 0 -> []; - ExtBits -> - [encode_small_length(ExtNum),<<ExtBits:ExtNum>>] - end. - -fixextensions(Pos,MaxPos,_,Acc) when Pos >= MaxPos -> - Acc; -fixextensions(Pos,ExtPos,Val,Acc) -> - Bit = case catch(element(Pos+1,Val)) of - asn1_NOVALUE -> - 0; - asn1_NOEXTVALUE -> - 0; - {'EXIT',_} -> - 0; - _ -> - 1 - end, - fixextensions(Pos+1,ExtPos,Val,(Acc bsl 1)+Bit). +-export([skipextensions/3]). +-export([complete/1, complete_NFP/1]). skipextensions(Bytes0, Nr, ExtensionBitstr) when is_bitstring(ExtensionBitstr) -> Prev = Nr - 1, @@ -122,249 +35,6 @@ skipextensions(Bytes0, Nr, ExtensionBitstr) when is_bitstring(ExtensionBitstr) - Bytes0 end. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% set_choice(Alt,Choices,Altnum) -> ListofBitSettings -%% Alt = atom() -%% Altnum = integer() | {integer(),integer()}% number of alternatives -%% Choices = [atom()] | {[atom()],[atom()]} -%% When Choices is a tuple the first list is the Rootset and the -%% second is the Extensions and then Altnum must also be a tuple with the -%% lengths of the 2 lists -%% -set_choice(Alt, {L1,L2}, {Len1,_Len2}) -> - case set_choice_tag(Alt, L1) of - N when is_integer(N), Len1 > 1 -> - [<<0:1>>, % the value is in the root set - encode_integer([{'ValueRange',{0,Len1-1}}],N)]; - N when is_integer(N) -> - <<0:1>>; % no encoding if only 0 or 1 alternative - false -> - [<<1:1>>, % extension value - case set_choice_tag(Alt,L2) of - N2 when is_integer(N2) -> - encode_small_number(N2); - false -> - unknown_choice_alt - end] - end; -set_choice(Alt,L,Len) -> - case set_choice_tag(Alt,L) of - N when is_integer(N), Len > 1 -> - encode_integer([{'ValueRange',{0,Len-1}}],N); - N when is_integer(N) -> - []; % no encoding if only 0 or 1 alternative - false -> - [unknown_choice_alt] - end. - -set_choice_tag(Alt,Choices) -> - set_choice_tag(Alt,Choices,0). - -set_choice_tag(Alt,[Alt|_Rest],Tag) -> - Tag; -set_choice_tag(Alt,[_H|Rest],Tag) -> - set_choice_tag(Alt,Rest,Tag+1); -set_choice_tag(_Alt,[],_Tag) -> - false. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% encode_open_type(Constraint, Value) -> CompleteList -%% Value = list of bytes of an already encoded value (the list must be flat) -%% | binary -%% Contraint = not used in this version -%% -encode_open_type(Val) -> - [encode_length(byte_size(Val)),Val]. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% encode_integer(Constraint,Value,NamedNumberList) -> CompleteList -%% encode_integer(Constraint,Value) -> CompleteList -%% encode_integer(Constraint,{Name,Value}) -> CompleteList -%% -%% -encode_integer(C, V, NamedNumberList) when is_atom(V) -> - case lists:keyfind(V, 1, NamedNumberList) of - {_,NewV} -> - encode_integer(C, NewV); - false -> - exit({error,{asn1,{namednumber,V}}}) - end; -encode_integer(C, V, _NamedNumberList) when is_integer(V) -> - encode_integer(C, V). - -encode_integer([{Rc,_Ec}],Val) when is_tuple(Rc) -> - try - [<<0:1>>,encode_integer([Rc], Val)] - catch - _:{error,{asn1,_}} -> - [<<1:1>>,encode_unconstrained_number(Val)] - end; -encode_integer(C, Val) when is_list(C) -> - case get_constraint(C, 'SingleValue') of - no -> - encode_integer1(C,Val); - V when is_integer(V), V =:= Val -> - []; % a type restricted to a single value encodes to nothing - V when is_list(V) -> - case lists:member(Val,V) of - true -> - encode_integer1(C,Val); - _ -> - exit({error,{asn1,{illegal_value,Val}}}) - end; - _ -> - exit({error,{asn1,{illegal_value,Val}}}) - end. - -encode_integer1(C, Val) -> - case VR = get_constraint(C, 'ValueRange') of - no -> - encode_unconstrained_number(Val); - {Lb,'MAX'} when Lb =< Val -> - encode_semi_constrained_number(Lb, Val); - %% positive with range - {Lb,Ub} when Val >= Lb, Ub >= Val -> - encode_constrained_number(VR,Val); - _ -> - exit({error,{asn1,{illegal_value,VR,Val}}}) - end. - -%% X.691:10.6 Encoding of a normally small non-negative whole number -%% Use this for encoding of CHOICE index if there is an extension marker in -%% the CHOICE -encode_small_number(Val) when Val < 64 -> - <<Val:7>>; -encode_small_number(Val) -> - [<<1:1>>|encode_semi_constrained_number(0, Val)]. - -%% X.691:10.7 Encoding of a semi-constrained whole number -encode_semi_constrained_number(Lb, Val) -> - %% encoding in minimum number of octets preceeded by a length - Val2 = Val - Lb, - Bin = eint_bin_positive(Val2), - Size = byte_size(Bin), - if - Size < 128 -> - [<<Size>>,Bin]; - Size < 16384 -> - [<<2:2,Size:14>>,Bin]; - true -> - [encode_length(Size),Bin] - end. - -encode_constrained_number({Lb,Ub}, Val) when Val >= Lb, Ub >= Val -> - Range = Ub - Lb + 1, - Val2 = Val - Lb, - NumBits = num_bits(Range), - <<Val2:NumBits>>; -encode_constrained_number(Range,Val) -> - exit({error,{asn1,{integer_range,Range,value,Val}}}). - -%% X.691:10.8 Encoding of an unconstrained whole number - -encode_unconstrained_number(Val) when Val >= 0 -> - Oct = eint_bin_2Cs(Val), - Len = byte_size(Oct), - if - Len < 128 -> - [<<Len>>,Oct]; % equiv with encode_length(undefined,Len) but faster - Len < 16384 -> - [<<2:2,Len:14>>,Oct]; - true -> - [encode_length(Len),<<Len:16>>,Oct] - end; -encode_unconstrained_number(Val) -> % negative - Oct = enint(Val,[]), - Len = byte_size(Oct), - if - Len < 128 -> - [<<Len>>,Oct]; % equiv with encode_length(undefined,Len) but faster - Len < 16384 -> - [<<2:2,Len:14>>,Oct]; - true -> - [encode_length(Len),Oct] - end. - - -eint_bin_2Cs(Int) -> - case eint_bin_positive(Int) of - <<B,_/binary>> = Bin when B > 16#7f -> - <<0,Bin/binary>>; - Bin -> Bin - end. - -%% returns the integer as a binary -eint_bin_positive(Val) when Val < 16#100 -> - <<Val>>; -eint_bin_positive(Val) when Val < 16#10000 -> - <<Val:16>>; -eint_bin_positive(Val) when Val < 16#1000000 -> - <<Val:24>>; -eint_bin_positive(Val) when Val < 16#100000000 -> - <<Val:32>>; -eint_bin_positive(Val) -> - list_to_binary([eint_bin_positive2(Val bsr 32),<<Val:32>>]). - -eint_bin_positive2(Val) when Val < 16#100 -> - <<Val>>; -eint_bin_positive2(Val) when Val < 16#10000 -> - <<Val:16>>; -eint_bin_positive2(Val) when Val < 16#1000000 -> - <<Val:24>>; -eint_bin_positive2(Val) when Val < 16#100000000 -> - <<Val:32>>; -eint_bin_positive2(Val) -> - [eint_bin_positive2(Val bsr 32),<<Val:32>>]. - - - - -enint(-1, [B1|T]) when B1 > 127 -> - list_to_binary([B1|T]); -enint(N, Acc) -> - enint(N bsr 8, [N band 16#ff|Acc]). - - -%% X.691:10.9 Encoding of a length determinant -%%encode_small_length(undefined,Len) -> % null means no UpperBound -%% encode_small_number(Len). - -%% X.691:10.9.3.5 -%% X.691:10.9.3.7 -encode_length(Len) -> % un-constrained - if - Len < 128 -> - <<Len>>; - Len < 16384 -> - <<2:2,Len:14>>; - true -> % should be able to endode length >= 16384 - error({error,{asn1,{encode_length,{nyi,above_16k}}}}) - end. - -encode_length({C,[]}, Len) -> - case C of - {Lb,Ub}=Vr when Lb =< Len, Len =< Ub -> - [<<0:1>>|encode_constrained_number(Vr, Len)]; - _ -> - [<<1:1>>|encode_length(Len)] - end; -encode_length(Len, Len) -> - []; -encode_length(Vr, Len) -> - encode_constrained_number(Vr, Len). - - -%% X.691 10.9.3.4 (only used for length of bitmap that prefixes extension -%% additions in a sequence or set -encode_small_length(Len) when Len =< 64 -> - <<(Len-1):7>>; -encode_small_length(Len) -> - [<<1:1>>,encode_length(Len)]. - - %% un-constrained decode_length(<<0:1,Oct:7,Rest/bitstring>>) -> {Oct,Rest}; @@ -373,575 +43,20 @@ decode_length(<<2:2,Val:14,Rest/bitstring>>) -> decode_length(<<3:2,_:14,_Rest/bitstring>>) -> exit({error,{asn1,{decode_length,{nyi,above_16k}}}}). - % X.691:11 -encode_boolean(true) -> - <<1:1>>; -encode_boolean(false) -> - <<0:1>>; -encode_boolean(Val) -> - exit({error,{asn1,{encode_boolean,Val}}}). - - -%%============================================================================ -%%============================================================================ -%% Bitstring value, ITU_T X.690 Chapter 8.5 -%%============================================================================ -%%============================================================================ - -%%============================================================================ -%% encode bitstring value -%%============================================================================ - - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% bitstring NamedBitList -%% Val can be of: -%% - [identifiers] where only named identifers are set to one, -%% the Constraint must then have some information of the -%% bitlength. -%% - [list of ones and zeroes] all bits -%% - integer value representing the bitlist -%% C is constraint Len, only valid when identifiers are present - - -%% when the value is a list of {Unused,BinBits}, where -%% Unused = integer(), -%% BinBits = binary(). - -encode_bit_string(C, Bits, NamedBitList) when is_bitstring(Bits) -> - PadLen = (8 - (bit_size(Bits) band 7)) band 7, - Compact = {PadLen,<<Bits/bitstring,0:PadLen>>}, - encode_bit_string(C, Compact, NamedBitList); -encode_bit_string(C, {Unused,BinBits}=Bin, NamedBitList) - when is_integer(Unused), is_binary(BinBits) -> - encode_bin_bit_string(C, Bin, NamedBitList); - -encode_bit_string(C, BitListVal, NamedBitList) -> - encode_bit_string1(C, BitListVal, NamedBitList). - -%% when the value is a list of named bits -encode_bit_string1(C, [FirstVal|_RestVal]=LoNB, NamedBitList) - when is_atom(FirstVal) -> - ToSetPos = get_all_bitposes(LoNB, NamedBitList, []), - BitList = make_and_set_list(ToSetPos, 0), - encode_bit_string1(C, BitList, NamedBitList); -encode_bit_string1(C, [{bit,_No}|_RestVal]=BL, NamedBitList) -> - ToSetPos = get_all_bitposes(BL, NamedBitList, []), - BitList = make_and_set_list(ToSetPos, 0), - encode_bit_string1(C, BitList, NamedBitList); -%% when the value is a list of ones and zeroes -encode_bit_string1(Int, BitListValue, _) - when is_list(BitListValue), is_integer(Int) -> - %% The type is constrained by a single value size constraint - bit_list2bitstr(Int, BitListValue); -encode_bit_string1(no, BitListValue, []) - when is_list(BitListValue) -> - Len = length(BitListValue), - [encode_length(Len),bit_list2bitstr(Len,BitListValue)]; -encode_bit_string1(C, BitListValue,[]) - when is_list(BitListValue) -> - Len = length(BitListValue), - [encode_length(C, Len),bit_list2bitstr(Len,BitListValue)]; -encode_bit_string1(no, BitListValue,_NamedBitList) - when is_list(BitListValue) -> - NewBitLVal = lists:reverse(lists:dropwhile(fun(0)->true;(1)->false end, - lists:reverse(BitListValue))), - Len = length(NewBitLVal), - [encode_length(Len),bit_list2bitstr(Len,NewBitLVal)]; -encode_bit_string1(C, BitListValue, _NamedBitList) - when is_list(BitListValue) ->% C = {_,'MAX'} - NewBitStr = bitstr_trailing_zeros(BitListValue, C), - [encode_length(C, bit_size(NewBitStr)),NewBitStr]; - - -%% when the value is an integer -encode_bit_string1(C, IntegerVal, NamedBitList) when is_integer(IntegerVal)-> - BitList = int_to_bitlist(IntegerVal), - encode_bit_string1(C, BitList, NamedBitList). - -bit_list2bitstr(Len,BitListValue) -> - case length(BitListValue) of - Len -> - << <<B:1>> || B <- BitListValue>>; - L when L > Len -> % truncate - <<(<< <<B:1>> || B <- BitListValue>>):Len/bitstring>>; - L -> % Len > L -> pad - <<(<< <<B:1>> || B <- BitListValue>>)/bitstring,0:(Len-L)>> - end. - -adjust_trailing_zeros(Len, Bin) when Len =:= bit_size(Bin) -> - Bin; -adjust_trailing_zeros(Len, Bin) when Len > bit_size(Bin) -> - <<Bin/bitstring,0:(Len-bit_size(Bin))>>; -adjust_trailing_zeros(Len,Bin) -> - <<Bin:Len/bitstring>>. - -bitstr_trailing_zeros(BitList, C) when is_integer(C) -> - bitstr_trailing_zeros1(BitList, C, C); -bitstr_trailing_zeros(BitList, {Lb,Ub}) when is_integer(Lb) -> - bitstr_trailing_zeros1(BitList,Lb,Ub); -bitstr_trailing_zeros(BitList, {{Lb,Ub},_}) when is_integer(Lb) -> - bitstr_trailing_zeros1(BitList, Lb, Ub); -bitstr_trailing_zeros(BitList, _) -> - bit_list2bitstr(length(BitList), BitList). - -bitstr_trailing_zeros1(BitList, Lb, Ub) -> - case length(BitList) of - Lb -> bit_list2bitstr(Lb, BitList); - B when B < Lb -> bit_list2bitstr(Lb, BitList); - D -> F = fun(L,LB,LB,_,_)->bit_list2bitstr(LB,lists:reverse(L)); - ([0|R],L1,LB,UB,Fun)->Fun(R,L1-1,LB,UB,Fun); - (L,L1,_,UB,_)when L1 =< UB -> - bit_list2bitstr(L1,lists:reverse(L)); - (_,_L1,_,_,_) ->exit({error,{list_length_BIT_STRING, - BitList}}) end, - F(lists:reverse(BitList),D,Lb,Ub,F) - end. - -%% encode_bin_bit_string/3, when value is a tuple of Unused and BinBits. -%% Unused = integer(),i.e. number unused bits in least sign. byte of -%% BinBits = binary(). -encode_bin_bit_string(C, {_,BinBits}, _NamedBitList) - when is_integer(C), C =< 16 -> - adjust_trailing_zeros(C, BinBits); -encode_bin_bit_string(C, {_Unused,BinBits}, _NamedBitList) - when is_integer(C) -> - adjust_trailing_zeros(C, BinBits); -encode_bin_bit_string(C, {_,_}=UnusedAndBin, NamedBitList) -> - %% removes all trailing bits if NamedBitList is not empty - BitStr = remove_trailing_bin(NamedBitList, UnusedAndBin), - case C of - {Lb,Ub} when is_integer(Lb),is_integer(Ub) -> - [encode_length({Lb,Ub},bit_size(BitStr)),BitStr]; - no -> - [encode_length(bit_size(BitStr)),BitStr]; - Sc -> - [encode_length(Sc,bit_size(BitStr)),BitStr] - end. - - -remove_trailing_bin([], {Unused,Bin}) -> - BS = bit_size(Bin)-Unused, - <<BitStr:BS/bitstring,_:Unused>> = Bin, - BitStr; -remove_trailing_bin(_NamedNumberList, {_Unused,<<>>}) -> - <<>>; -remove_trailing_bin(NamedNumberList, {_Unused,Bin}) -> - Size = byte_size(Bin)-1, - <<Bfront:Size/binary, LastByte:8>> = Bin, - - %% clear the Unused bits to be sure - Unused1 = trailingZeroesInNibble(LastByte band 15), - Unused2 = - case Unused1 of - 4 -> - 4 + trailingZeroesInNibble(LastByte bsr 4); - _ -> Unused1 - end, - case Unused2 of - 8 -> - remove_trailing_bin(NamedNumberList,{0,Bfront}); - _ -> - BS = bit_size(Bin) - Unused2, - <<BitStr:BS/bitstring,_:Unused2>> = Bin, - BitStr - end. - -trailingZeroesInNibble(0) -> - 4; -trailingZeroesInNibble(1) -> - 0; -trailingZeroesInNibble(2) -> - 1; -trailingZeroesInNibble(3) -> - 0; -trailingZeroesInNibble(4) -> - 2; -trailingZeroesInNibble(5) -> - 0; -trailingZeroesInNibble(6) -> - 1; -trailingZeroesInNibble(7) -> - 0; -trailingZeroesInNibble(8) -> - 3; -trailingZeroesInNibble(9) -> - 0; -trailingZeroesInNibble(10) -> - 1; -trailingZeroesInNibble(11) -> - 0; -trailingZeroesInNibble(12) -> %#1100 - 2; -trailingZeroesInNibble(13) -> - 0; -trailingZeroesInNibble(14) -> - 1; -trailingZeroesInNibble(15) -> - 0. - - -%%%%%%%%%%%%%%% -%% - -int_to_bitlist(Int) when is_integer(Int), Int > 0 -> - [Int band 1 | int_to_bitlist(Int bsr 1)]; -int_to_bitlist(0) -> - []. - - -%%%%%%%%%%%%%%%%%% -%% get_all_bitposes([list of named bits to set], named_bit_db, []) -> -%% [sorted_list_of_bitpositions_to_set] - -get_all_bitposes([{bit,ValPos}|Rest], NamedBitList, Ack) -> - get_all_bitposes(Rest, NamedBitList, [ValPos | Ack ]); - -get_all_bitposes([Val | Rest], NamedBitList, Ack) -> - case lists:keyfind(Val, 1, NamedBitList) of - {_ValName, ValPos} -> - get_all_bitposes(Rest, NamedBitList, [ValPos | Ack]); - false -> - exit({error,{asn1, {bitstring_namedbit, Val}}}) - end; -get_all_bitposes([], _NamedBitList, Ack) -> - lists:sort(Ack). - -%%%%%%%%%%%%%%%%%% -%% make_and_set_list([list of positions to set to 1])-> -%% returns list with all in SetPos set. -%% in positioning in list the first element is 0, the second 1 etc.., but -%% - -make_and_set_list([XPos|SetPos], XPos) -> - [1 | make_and_set_list(SetPos, XPos + 1)]; -make_and_set_list([Pos|SetPos], XPos) -> - [0 | make_and_set_list([Pos | SetPos], XPos + 1)]; -make_and_set_list([], _) -> - []. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% X.691:16 -%% encode_octet_string(Val) -%% encode_octet_string(Constraint, Val) -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -encode_octet_string(Val) -> - try - [encode_length(length(Val)),list_to_binary(Val)] - catch - error:{error,{asn1,{encode_length,_}}} -> - encode_fragmented_octet_string(Val) - end. - -encode_octet_string(C, Val) -> - case C of - {_,_}=VR -> - try - [encode_length(VR, length(Val)),list_to_binary(Val)] - catch - error:{error,{asn1,{encode_length,_}}} -> - encode_fragmented_octet_string(Val) - end; - Sv when is_integer(Sv), Sv =:= length(Val) -> % fixed length - list_to_binary(Val) - end. - - -encode_fragmented_octet_string(Val) -> - Bin = list_to_binary(Val), - efos_1(Bin). - -efos_1(<<B:16#10000/binary,T/binary>>) -> - [<<3:2,4:6>>,B|efos_1(T)]; -efos_1(<<B:16#C000/binary,T/binary>>) -> - [<<3:2,3:6>>,B|efos_1(T)]; -efos_1(<<B:16#8000/binary,T/binary>>) -> - [<<3:2,2:6>>,B|efos_1(T)]; -efos_1(<<B:16#4000/binary,T/binary>>) -> - [<<3:2,1:6>>,B|efos_1(T)]; -efos_1(<<B/bitstring>>) -> - Len = byte_size(B), - [encode_length(Len),B]. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% Restricted char string types -%% (NumericString, PrintableString,VisibleString,IA5String,BMPString,UniversalString) -%% X.691:26 and X.680:34-36 -%%encode_restricted_string('BMPString',Constraints,Extension,Val) - - -encode_restricted_string(Val) when is_list(Val)-> - [encode_length(length(Val)),list_to_binary(Val)]. - -encode_known_multiplier_string(StringType, C, Pa, Val) -> - Result = chars_encode(Pa, StringType, Val), - case C of - Ub when is_integer(Ub) -> - Result; - {_,_}=Range -> - [encode_length(Range, length(Val)),Result]; - no -> - [encode_length(length(Val)),Result] - end. - -encode_NumericString(C, Pa, Val) -> - encode_known_multiplier_string('NumericString', C, Pa, Val). - -encode_PrintableString(C, Pa, Val) -> - encode_known_multiplier_string('PrintableString', C, Pa, Val). - -encode_VisibleString(C, Pa, Val) -> % equivalent with ISO646String - encode_known_multiplier_string('VisibleString', C, Pa, Val). - -encode_IA5String(C, Pa, Val) -> - encode_known_multiplier_string('IA5String', C, Pa, Val). - -encode_BMPString(C, Pa, Val) -> - encode_known_multiplier_string('BMPString', C, Pa, Val). - -encode_UniversalString(C, Pa, Val) -> - encode_known_multiplier_string('UniversalString', C, Pa, Val). - - -%% end of known-multiplier strings for which PER visible constraints are -%% applied - -encode_GeneralString(_C,Val) -> - encode_restricted_string(Val). - -encode_GraphicString(_C,Val) -> - encode_restricted_string(Val). - -encode_ObjectDescriptor(_C,Val) -> - encode_restricted_string(Val). - -encode_TeletexString(_C,Val) -> % equivalent with T61String - encode_restricted_string(Val). - -encode_VideotexString(_C,Val) -> - encode_restricted_string(Val). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% chars_encode(C,StringType,Value) -> ValueList -%% -%% encodes chars according to the per rules taking the constraint PermittedAlphabet -%% into account. -%% This function does only encode the value part and NOT the length - -chars_encode(Pa, StringType, Value) -> - case {StringType,Pa} of - {'UniversalString',{_,_Sv}} -> - exit({error,{asn1,{'not implemented',"UniversalString with PermittedAlphabet constraint"}}}); - {'BMPString',{_,_Sv}} -> - exit({error,{asn1,{'not implemented',"BMPString with PermittedAlphabet constraint"}}}); - _ -> - {NumBits,CharOutTab} = {get_NumBits(Pa, StringType), - get_CharOutTab(Pa, StringType)}, - chars_encode2(Value,NumBits,CharOutTab) - end. - -chars_encode2([H|T],NumBits,{Min,Max,notab}) when H =< Max, H >= Min -> - [<<(H-Min):NumBits>>|chars_encode2(T,NumBits,{Min,Max,notab})]; -chars_encode2([H|T],NumBits,{Min,Max,Tab}) when H =< Max, H >= Min -> - Ch = exit_if_false(H,element(H-Min+1,Tab)), - [<<Ch:NumBits>>|chars_encode2(T,NumBits,{Min,Max,Tab})]; -chars_encode2([{A,B,C,D}|T],NumBits,{Min,Max,notab}) -> - %% no value range check here (ought to be, but very expensive) - Ch = ((((((A bsl 8)+B) bsl 8)+C) bsl 8)+D)-Min, - [<<Ch:NumBits>>|chars_encode2(T,NumBits,{Min,Max,notab})]; -chars_encode2([{A,B,C,D}|T],NumBits,{Min,Max,Tab}) -> - %% no value range check here (ought to be, but very expensive) - Ch = exit_if_false({A,B,C,D},element(((((((A bsl 8)+B) bsl 8)+C) bsl 8)+D)-Min,Tab)), - [<<Ch:NumBits>>|chars_encode2(T,NumBits,{Min,Max,notab})]; -chars_encode2([H|_T],_,{_,_,_}) -> - exit({error,{asn1,{illegal_char_value,H}}}); -chars_encode2([],_,_) -> - []. - -exit_if_false(V,false)-> - exit({error,{asn1,{"illegal value according to Permitted alphabet constraint",V}}}); -exit_if_false(_,V) ->V. - - -get_NumBits(Pa, StringType) -> - case Pa of - {'SingleValue',Sv} -> - charbits(length(Sv)); - no -> - case StringType of - 'IA5String' -> - charbits(128); % 16#00..16#7F - 'VisibleString' -> - charbits(95); % 16#20..16#7E - 'PrintableString' -> - charbits(74); % [$\s,$',$(,$),$+,$,,$-,$.,$/,"0123456789",$:,$=,$?,$A..$Z,$a..$z - 'NumericString' -> - charbits(11); % $ ,"0123456789" - 'UniversalString' -> - 32; - 'BMPString' -> - 16 - end - end. - -get_CharOutTab(Pa, StringType) -> - case Pa of - {'SingleValue',Sv} -> - get_CharTab2(Pa, StringType, hd(Sv), lists:max(Sv), Sv); - no -> - case StringType of - 'IA5String' -> - {0,16#7F,notab}; - 'VisibleString' -> - get_CharTab2(Pa, StringType, 16#20, 16#7F, notab); - 'PrintableString' -> - Chars = lists:sort( - " '()+,-./0123456789:=?ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"), - get_CharTab2(Pa, StringType, hd(Chars), - lists:max(Chars), Chars); - 'NumericString' -> - get_CharTab2(Pa, StringType, 16#20, $9, " 0123456789"); - 'UniversalString' -> - {0,16#FFFFFFFF,notab}; - 'BMPString' -> - {0,16#FFFF,notab} - end - end. - -get_CharTab2(C,StringType,Min,Max,Chars) -> - BitValMax = (1 bsl get_NumBits(C,StringType))-1, - if - Max =< BitValMax -> - {0,Max,notab}; - true -> - {Min,Max,create_char_tab(Min,Chars)} - end. - -create_char_tab(Min,L) -> - list_to_tuple(create_char_tab(Min,L,0)). -create_char_tab(Min,[Min|T],V) -> - [V|create_char_tab(Min+1,T,V+1)]; -create_char_tab(_Min,[],_V) -> - []; -create_char_tab(Min,L,V) -> - [false|create_char_tab(Min+1,L,V)]. - -%% See Table 20.3 in Dubuisson -charbits(NumOfChars) when NumOfChars =< 2 -> 1; -charbits(NumOfChars) when NumOfChars =< 4 -> 2; -charbits(NumOfChars) when NumOfChars =< 8 -> 3; -charbits(NumOfChars) when NumOfChars =< 16 -> 4; -charbits(NumOfChars) when NumOfChars =< 32 -> 5; -charbits(NumOfChars) when NumOfChars =< 64 -> 6; -charbits(NumOfChars) when NumOfChars =< 128 -> 7; -charbits(NumOfChars) when NumOfChars =< 256 -> 8; -charbits(NumOfChars) when NumOfChars =< 512 -> 9; -charbits(NumOfChars) when NumOfChars =< 1024 -> 10; -charbits(NumOfChars) when NumOfChars =< 2048 -> 11; -charbits(NumOfChars) when NumOfChars =< 4096 -> 12; -charbits(NumOfChars) when NumOfChars =< 8192 -> 13; -charbits(NumOfChars) when NumOfChars =< 16384 -> 14; -charbits(NumOfChars) when NumOfChars =< 32768 -> 15; -charbits(NumOfChars) when NumOfChars =< 65536 -> 16; -charbits(NumOfChars) when is_integer(NumOfChars) -> - 16 + charbits1(NumOfChars bsr 16). - -charbits1(0) -> - 0; -charbits1(NumOfChars) -> - 1 + charbits1(NumOfChars bsr 1). - - -%% UTF8String -encode_UTF8String(Val) when is_binary(Val) -> - [encode_length(byte_size(Val)),Val]; -encode_UTF8String(Val) -> - Bin = list_to_binary(Val), - encode_UTF8String(Bin). - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% encode_object_identifier(Val) -> CompleteList -%% encode_object_identifier({Name,Val}) -> CompleteList -%% Val -> {Int1,Int2,...,IntN} % N >= 2 -%% Name -> atom() -%% Int1 -> integer(0..2) -%% Int2 -> integer(0..39) when Int1 (0..1) else integer() -%% Int3-N -> integer() -%% CompleteList -> [binary()|bitstring()|list()] -%% -encode_object_identifier(Val) -> - OctetList = e_object_identifier(Val), - Octets = list_to_binary(OctetList), % performs a flatten at the same time - [encode_length(byte_size(Octets)),Octets]. - -%% This code is copied from asn1_encode.erl (BER) and corrected and modified - -e_object_identifier({'OBJECT IDENTIFIER',V}) -> - e_object_identifier(V); -e_object_identifier(V) when is_tuple(V) -> - e_object_identifier(tuple_to_list(V)); - -%% E1 = 0|1|2 and (E2 < 40 when E1 = 0|1) -e_object_identifier([E1,E2|Tail]) when E1 >= 0, E1 < 2, E2 < 40 ; E1==2 -> - Head = 40*E1 + E2, % weird - e_object_elements([Head|Tail],[]); -e_object_identifier(Oid=[_,_|_Tail]) -> - exit({error,{asn1,{'illegal_value',Oid}}}). - -e_object_elements([],Acc) -> - lists:reverse(Acc); -e_object_elements([H|T],Acc) -> - e_object_elements(T,[e_object_element(H)|Acc]). - -e_object_element(Num) when Num < 128 -> - [Num]; -e_object_element(Num) -> - [e_o_e(Num bsr 7)|[Num band 2#1111111]]. -e_o_e(Num) when Num < 128 -> - Num bor 2#10000000; -e_o_e(Num) -> - [e_o_e(Num bsr 7)|[(Num band 2#1111111) bor 2#10000000]]. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% encode_relative_oid(Val) -> CompleteList -%% encode_relative_oid({Name,Val}) -> CompleteList -encode_relative_oid(Val) when is_tuple(Val) -> - encode_relative_oid(tuple_to_list(Val)); -encode_relative_oid(Val) when is_list(Val) -> - Octets = list_to_binary([e_object_element(X)||X <- Val]), - [encode_length(byte_size(Octets)),Octets]. - - -get_constraint([{Key,V}],Key) -> - V; -get_constraint([],_Key) -> - no; -get_constraint(C,Key) -> - case lists:keyfind(Key, 1, C) of - false -> - no; - {_,V} -> - V - end. - %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% complete(InList) -> ByteList %% Takes a coded list with bits and bytes and converts it to a list of bytes %% Should be applied as the last step at encode of a complete ASN.1 type %% complete(InList) when is_list(InList) -> - case complete1(InList) of + case list_to_bitstring(InList) of <<>> -> <<0>>; Res -> - case bit_size(Res) band 7 of + Sz = bit_size(Res), + case Sz band 7 of 0 -> Res; - Bits -> <<Res/bitstring,0:(8-Bits)>> + Bits -> <<Res:Sz/bitstring,0:(8-Bits)>> end end; complete(Bin) when is_binary(Bin) -> @@ -950,24 +65,12 @@ complete(Bin) when is_binary(Bin) -> _ -> Bin end; complete(InList) when is_bitstring(InList) -> - PadLen = 8 - (bit_size(InList) band 7), - <<InList/bitstring,0:PadLen>>. - -complete1(L) when is_list(L) -> - list_to_bitstring(L). + Sz = bit_size(InList), + PadLen = 8 - (Sz band 7), + <<InList:Sz/bitstring,0:PadLen>>. %% Special version of complete that does not align the completed message. complete_NFP(InList) when is_list(InList) -> list_to_bitstring(InList); complete_NFP(InList) when is_bitstring(InList) -> InList. - -%% unaligned helpers - -%% 10.5.6 NOTE: If "range" satisfies the inequality 2^m < "range" =< -%% 2^(m+1) then the number of bits = m + 1 - -num_bits(N) -> num_bits(N, 1, 0). - -num_bits(N,T,B) when N =< T -> B; -num_bits(N,T,B) -> num_bits(N, T bsl 1, B+1). diff --git a/lib/asn1/test/Makefile b/lib/asn1/test/Makefile index 15b97df972..a3fa4f2968 100644 --- a/lib/asn1/test/Makefile +++ b/lib/asn1/test/Makefile @@ -82,6 +82,7 @@ MODULES= \ testInfObjectClass \ testInfObj \ testParameterizedInfObj \ + testFragmented \ testMergeCompile \ testMultipleLevels \ testDeepTConstr \ diff --git a/lib/asn1/test/asn1_SUITE.erl b/lib/asn1/test/asn1_SUITE.erl index f00b23a8b2..9a149a495a 100644 --- a/lib/asn1/test/asn1_SUITE.erl +++ b/lib/asn1/test/asn1_SUITE.erl @@ -150,6 +150,7 @@ groups() -> per_open_type, testInfObjectClass, testParameterizedInfObj, + testFragmented, testMergeCompile, testobj, testDeepTConstr, @@ -186,8 +187,7 @@ groups() -> {performance, [], [testTimer_ber, testTimer_per, - testTimer_uper, - smp]}]. + testTimer_uper]}]. parallel(Options) -> case erlang:system_info(smp_support) andalso @@ -360,7 +360,8 @@ testPrimStrings_cases(Rule) -> testPrimStrings:universal_string(Rule), testPrimStrings:bmp_string(Rule), testPrimStrings:times(Rule), - testPrimStrings:utf8_string(Rule). + testPrimStrings:utf8_string(Rule), + testPrimStrings:fragmented(Rule). testPrimExternal(Config) -> test(Config, fun testPrimExternal/3). testPrimExternal(Config, Rule, Opts) -> @@ -452,7 +453,7 @@ testSeqDefault(Config, Rule, Opts) -> asn1_test_lib:compile("SeqDefault", Config, [Rule|Opts]), testSeqDefault:main(Rule). -testSeqExtension(Config) -> test(Config, fun testSeqExtension/3). +testSeqExtension(Config) -> test(Config, fun testSeqExtension/3, [ber,uper]). testSeqExtension(Config, Rule, Opts) -> asn1_test_lib:compile_all(["External", "SeqExtension", @@ -830,6 +831,12 @@ testParameterizedInfObj(Config, Rule, Opts) -> asn1_test_lib:compile_all(Files, Config, [Rule|Opts]), testParameterizedInfObj:main(Config, Rule). +testFragmented(Config) -> + test(Config, fun testFragmented/3). +testFragmented(Config, Rule, Opts) -> + asn1_test_lib:compile("Fragmented", Config, [Rule|Opts]), + testFragmented:main(Rule). + testMergeCompile(Config) -> test(Config, fun testMergeCompile/3). testMergeCompile(Config, Rule, Opts) -> Files = ["MS.set.asn", "RANAPSET.set.asn1", "Mvrasn4.set.asn", @@ -1230,70 +1237,6 @@ ticket_7407(Config) -> [uper, no_final_padding]), asn1_test_lib:ticket_7407_code(false). -smp(suite) -> []; -smp(Config) -> - case erlang:system_info(smp_support) of - true -> - NumOfProcs = erlang:system_info(schedulers), - io:format("smp starting ~p workers\n",[NumOfProcs]), - - Msg = {initiatingMessage, testNBAPsystem:cell_setup_req_msg()}, - ok = testNBAPsystem:compile(Config, [per]), - - enc_dec(NumOfProcs,Msg,2), - - N = 10000, - - {Time1,ok} = timer:tc(?MODULE,enc_dec,[NumOfProcs,Msg, N]), - {Time1S,ok} = timer:tc(?MODULE,enc_dec,[1, Msg, NumOfProcs * N]), - - ok = testNBAPsystem:compile(Config, [ber]), - {Time3,ok} = timer:tc(?MODULE,enc_dec,[NumOfProcs,Msg, N]), - - {Time3S,ok} = timer:tc(?MODULE,enc_dec,[1, Msg, NumOfProcs * N]), - - {comment,lists:flatten( - io_lib:format( - "Encode/decode time parallell with ~p cores: ~p [microsecs]~n" - "Encode/decode time sequential: ~p [microsecs]", - [NumOfProcs,Time1+Time3,Time1S+Time3S]))}; - false -> - {skipped,"No smp support"} - end. - -enc_dec(1, Msg, N) -> - worker_loop(N, Msg); -enc_dec(NumOfProcs,Msg, N) -> - pforeach(fun(_) -> - worker_loop(N, Msg) - end, [I || I <- lists:seq(1,NumOfProcs)]). - -worker_loop(0, _Msg) -> - ok; -worker_loop(N, Msg) -> - {ok,B}=asn1_wrapper:encode('NBAP-PDU-Discriptions', - 'NBAP-PDU', - Msg), - {ok,_Msg}=asn1_wrapper:decode('NBAP-PDU-Discriptions', - 'NBAP-PDU', - B), - worker_loop(N - 1, Msg). - - -pforeach(Fun, List) -> - pforeach(Fun, List, []). -pforeach(Fun, [], [{Pid,Ref}|Pids]) -> - receive - {'DOWN', Ref, process, Pid, normal} -> - pforeach(Fun, [], Pids) - end; -pforeach(Fun, [H|T], Pids) -> - Pid = spawn(fun() -> Fun(H) end), - Ref = erlang:monitor(process, Pid), - pforeach(Fun, T, [{Pid, Ref}|Pids]); -pforeach(_Fun,[],[]) -> - ok. - -record('InitiatingMessage',{procedureCode,criticality,value}). -record('Iu-ReleaseCommand',{first,second}). diff --git a/lib/asn1/test/asn1_SUITE_data/Fragmented.asn1 b/lib/asn1/test/asn1_SUITE_data/Fragmented.asn1 new file mode 100644 index 0000000000..bfc939737f --- /dev/null +++ b/lib/asn1/test/asn1_SUITE_data/Fragmented.asn1 @@ -0,0 +1,24 @@ +Fragmented DEFINITIONS AUTOMATIC TAGS ::= +BEGIN + +FUNCTION ::= CLASS { + &code INTEGER UNIQUE, + &b BOOLEAN, + &ArgumentType +} + +SS ::= SEQUENCE OF OCTET STRING + +val1 FUNCTION ::= { + &code 1, &b FALSE, &ArgumentType SS +} + +ObjSet FUNCTION ::= { val1 } + +PDU ::= SEQUENCE { + code FUNCTION.&code ({ObjSet}), + b FUNCTION.&b ({ObjSet}{@code}), + arg FUNCTION.&ArgumentType ({ObjSet}{@code}) +} + +END diff --git a/lib/asn1/test/asn1_SUITE_data/InfObj.asn b/lib/asn1/test/asn1_SUITE_data/InfObj.asn index 53e5043cb7..880e81c3b1 100644 --- a/lib/asn1/test/asn1_SUITE_data/InfObj.asn +++ b/lib/asn1/test/asn1_SUITE_data/InfObj.asn @@ -202,7 +202,11 @@ constructed2 CONSTRUCTED-DEFAULT ::= { &id 2, &ok false } ConstructedDefaultSet CONSTRUCTED-DEFAULT ::= { constructed1 | constructed2 | - { &id 3, &Type BOOLEAN } + { &id 3, &Type BOOLEAN } | + { &id 4, &Type SET { a INTEGER, b BIT STRING } } | + { &id 5, &Type CHOICE { i INTEGER, b BIT STRING } } | + { &id 6, &Type SEQUENCE OF INTEGER (1..16) } | + { &id 7, &Type SET OF INTEGER (1..64) } } ConstructedPdu ::= SEQUENCE { @@ -210,6 +214,47 @@ ConstructedPdu ::= SEQUENCE { content CONSTRUCTED-DEFAULT.&Type ({ConstructedDefaultSet}{@id}) } +ConstructedSet ::= SET { + id [0] CONSTRUCTED-DEFAULT.&id ({ConstructedDefaultSet}), + content [1] CONSTRUCTED-DEFAULT.&Type ({ConstructedDefaultSet}{@id}) +} + +-- Test OPTIONAL and DEFAULT + +OptionalInSeq ::= SEQUENCE { + id CONSTRUCTED-DEFAULT.&id ({ConstructedDefaultSet}), + content CONSTRUCTED-DEFAULT.&Type ({ConstructedDefaultSet}{@id}) OPTIONAL +} + +DefaultInSeq ::= SEQUENCE { + id CONSTRUCTED-DEFAULT.&id ({ConstructedDefaultSet}), + content CONSTRUCTED-DEFAULT.&Type ({ConstructedDefaultSet}{@id}) + DEFAULT BOOLEAN:TRUE +} + +-- Test more than one optional typefield table constraint in a SEQUENCE. + +MULTIPLE-OPTIONALS ::= CLASS { + &id INTEGER UNIQUE, + &T1, + &T2, + &T3 +} + +multiple-optionals-1 MULTIPLE-OPTIONALS ::= + {&id 1, &T1 INTEGER, &T2 BOOLEAN, &T3 OCTET STRING} + +Multiple-Optionals-Set MULTIPLE-OPTIONALS ::= { + multiple-optionals-1 +} + +Multiple-Optionals ::= SEQUENCE { + id MULTIPLE-OPTIONALS.&id ({Multiple-Optionals-Set}), + t1 [0] MULTIPLE-OPTIONALS.&T1 ({Multiple-Optionals-Set}{@id}) OPTIONAL, + t2 [1] MULTIPLE-OPTIONALS.&T2 ({Multiple-Optionals-Set}{@id}) OPTIONAL, + t3 [2] MULTIPLE-OPTIONALS.&T3 ({Multiple-Optionals-Set}{@id}) OPTIONAL +} + END diff --git a/lib/asn1/test/asn1_SUITE_data/Param.asn1 b/lib/asn1/test/asn1_SUITE_data/Param.asn1 index b2987a7885..4eff0da781 100644 --- a/lib/asn1/test/asn1_SUITE_data/Param.asn1 +++ b/lib/asn1/test/asn1_SUITE_data/Param.asn1 @@ -88,6 +88,28 @@ POS2 {CONFIG-DATA:obj} ::= OCTET STRING (SIZE(obj.&minLevel .. obj.&maxLevel)) OS2 ::= POS2 {config-data} +-- +-- Test a CLASS without the user-friendly syntax. +-- + +CL ::= CLASS { + &code INTEGER UNIQUE, + &Data +} + +P{T} ::= CHOICE { a INTEGER, b T } + +o1 CL ::= { + &code 42, + &Data P{BOOLEAN} +} + +SetCL CL ::= { o1 } + +Scl ::= SEQUENCE { + code CL.&code ({SetCL}), + data CL.&Data ({SetCL}{@code}) +} END diff --git a/lib/asn1/test/asn1_SUITE_data/SeqOf.asn1 b/lib/asn1/test/asn1_SUITE_data/SeqOf.asn1 index 888dbe5dd7..670f827f5e 100644 --- a/lib/asn1/test/asn1_SUITE_data/SeqOf.asn1 +++ b/lib/asn1/test/asn1_SUITE_data/SeqOf.asn1 @@ -31,7 +31,43 @@ Seq4 ::= SEQUENCE seq43 [43] SEQUENCE OF SeqIn DEFAULT {} } +Seq5 ::= SEQUENCE { + b BOOLEAN, + s SEQUENCE SIZE (0..3) OF OCTET STRING (SIZE (0..3)), + -- If 's' is empty, 'magic' should not be aligned. + magic INTEGER (0..127) +} + +Seq6 ::= SEQUENCE { + a SEQUENCE OF INTEGER (0..7), + b SEQUENCE (SIZE (0..7)) OF INTEGER (0..7), + -- 'magic' should never be aligned. + magic INTEGER (0..127) +} +Seq7 ::= SEQUENCE { + a SEQUENCE OF INTEGER (1..512), + b SEQUENCE (SIZE (0..255)) OF INTEGER (1..512), + i INTEGER +} + +Seq8 ::= SEQUENCE { + sof SEQUENCE (SIZE (0..3)) OF OCTET STRING (SIZE (3)), + -- Not aligned here if the size of 'sof' is zero. + i INTEGER (0..127) +} + +Seq9 ::= SEQUENCE { + b BOOLEAN, + s SEQUENCE SIZE (0..3) OF OCTET STRING (SIZE (0..3)), + magic INTEGER (0..127) +} + +Seq10 ::= SEQUENCE { + b BOOLEAN, + s SEQUENCE SIZE (1..3) OF OCTET STRING (SIZE (0..3)), + magic INTEGER (0..127) +} SeqIn ::= SEQUENCE { @@ -50,9 +86,6 @@ SeqCho ::= SEQUENCE OF CHOICE {bool BOOLEAN, SeqOfInt ::= SEQUENCE OF INTEGER - - - SeqEmp ::= SEQUENCE { seq1 SEQUENCE OF Empty DEFAULT {} diff --git a/lib/asn1/test/asn1_SUITE_data/TConstr.asn1 b/lib/asn1/test/asn1_SUITE_data/TConstr.asn1 index e2e0a11dc4..b2b2de2f56 100644 --- a/lib/asn1/test/asn1_SUITE_data/TConstr.asn1 +++ b/lib/asn1/test/asn1_SUITE_data/TConstr.asn1 @@ -58,6 +58,40 @@ Deeper ::= SEQUENCE { b SEQUENCE {ba INTEGER, bb MYCLASS.&Type ({ObjectSet}{@a.s.ab})} } +Seq3 ::= SEQUENCE { + a SEQUENCE { + aa INTEGER, + ab MYCLASS.&id ({ObjectSet}) + }, + -- Multiple references from the same SEQUENCE... + b SEQUENCE { + ba MYCLASS.&Type ({ObjectSet}{@a.ab}), + bb MYCLASS.&Result ({ObjectSet}{@a.ab}), + -- ... and references from multiple SEQUENCEs... + bc SEQUENCE { + bca MYCLASS.&Result ({ObjectSet}{@a.ab}), + bcb MYCLASS.&Type ({ObjectSet}{@a.ab}) + } + } +} + +Seq3-Opt ::= SEQUENCE { + a SEQUENCE { + aa INTEGER, + ab MYCLASS.&id ({ObjectSet}) + }, + -- Multiple references from the same SEQUENCE... + b SEQUENCE { + ba MYCLASS.&Type ({ObjectSet}{@a.ab}) OPTIONAL, + bb MYCLASS.&Result ({ObjectSet}{@a.ab}) OPTIONAL, + -- ... and references from multiple SEQUENCEs... + bc SEQUENCE { + bca MYCLASS.&Result ({ObjectSet}{@a.ab}), + bcb MYCLASS.&Type ({ObjectSet}{@a.ab}) + } OPTIONAL + } +} + -- following from Peter's definitions diff --git a/lib/asn1/test/error_SUITE.erl b/lib/asn1/test/error_SUITE.erl index a94a6d95a0..6451f81c01 100644 --- a/lib/asn1/test/error_SUITE.erl +++ b/lib/asn1/test/error_SUITE.erl @@ -19,7 +19,7 @@ -module(error_SUITE). -export([suite/0,all/0,groups/0, - already_defined/1,enumerated/1]). + already_defined/1,enumerated/1,objects/1]). -include_lib("test_server/include/test_server.hrl"). @@ -30,7 +30,8 @@ all() -> groups() -> [{p,parallel(),[already_defined, - enumerated]}]. + enumerated, + objects]}]. parallel() -> case erlang:system_info(schedulers) > 1 of @@ -95,6 +96,48 @@ enumerated(Config) -> } = run(P, Config), ok. +objects(Config) -> + M = 'Objects', + P = {M, + <<"Objects DEFINITIONS AUTOMATIC TAGS ::= BEGIN\n" + " obj1 CL ::= { &wrong 42 }\n" + " obj2 CL ::= { &wrong 1, &Wrong INTEGER }\n" + " obj3 CL ::= { &Data OCTET STRING }\n" + " obj4 SMALL ::= { &code 42 }\n" + " InvalidSet CL ::= { obj1 }\n" + + " CL ::= CLASS {\n" + " &code INTEGER UNIQUE,\n" + " &enum ENUMERATED { a, b, c},\n" + " &Data,\n" + " &object CL,\n" + " &Set CL,\n" + " &vartypevalue &Data,\n" + " &VarTypeValue &Data\n" + " }\n" + + " SMALL ::= CLASS {\n" + " &code INTEGER UNIQUE,\n" + " &i INTEGER\n" + " }\n" + "END\n">>}, + {error, + [ + {structured_error,{M,2},asn1ct_check, + {invalid_fields,[wrong],obj1}}, + {structured_error,{M,3},asn1ct_check, + {invalid_fields,['Wrong',wrong],obj2}}, + {structured_error,{M,4},asn1ct_check, + {missing_mandatory_fields,['Set','VarTypeValue',code, + enum,object,vartypevalue],obj3}}, + {structured_error,{M,5},asn1ct_check, + {missing_mandatory_fields,[i],obj4}}, + {structured_error,{M,6},asn1ct_check, + {invalid_fields,[wrong],'InvalidSet'}} + ] + } = run(P, Config), + ok. + run({Mod,Spec}, Config) -> diff --git a/lib/asn1/test/testDeepTConstr.erl b/lib/asn1/test/testDeepTConstr.erl index f17dedc043..620b5f3356 100644 --- a/lib/asn1/test/testDeepTConstr.erl +++ b/lib/asn1/test/testDeepTConstr.erl @@ -40,8 +40,7 @@ main(_Erule) -> {any,"DK"}, {final,"NO"}]}}, - {ok,Bytes1} = 'TConstrChoice':encode('FilterItem', Val1), - {error,Reason} = asn1_wrapper:decode('TConstrChoice','FilterItem',Bytes1), + Reason = must_fail('TConstrChoice', 'FilterItem', Val1), io:format("Reason: ~p~n~n",[Reason]), {ok,Bytes2} = 'TConstrChoice':encode('FilterItem', Val2), {ok,Res} = 'TConstrChoice':decode('FilterItem', Bytes2), @@ -70,6 +69,21 @@ main(_Erule) -> {'Deeper_a',12, {'Deeper_a_s',{2,4},42}}, {'Deeper_b',13,{'Type-object1',14,true}}}), + + roundtrip('TConstr', 'Seq3', + {'Seq3', + {'Seq3_a',42,'TConstr':'id-object1'()}, + {'Seq3_b', + {'Type-object1',-777,true}, + 12345, + {'Seq3_b_bc',12345789,{'Type-object1',-999,true}}}}), + roundtrip('TConstr', 'Seq3-Opt', + {'Seq3-Opt', + {'Seq3-Opt_a',42,'TConstr':'id-object1'()}, + {'Seq3-Opt_b', + {'Type-object1',-777,true}, + 12345, + {'Seq3-Opt_b_bc',12345789,{'Type-object1',-999,true}}}}), ok. @@ -77,3 +91,13 @@ roundtrip(M, T, V) -> {ok,E} = M:encode(T, V), {ok,V} = M:decode(T, E), ok. + +%% Either encoding or decoding must fail. +must_fail(M, T, V) -> + case M:encode(T, V) of + {ok,E} -> + {error,Reason} = M:decode(T, E), + Reason; + {error,Reason} -> + Reason + end. diff --git a/lib/asn1/test/testFragmented.erl b/lib/asn1/test/testFragmented.erl new file mode 100644 index 0000000000..c391ba8305 --- /dev/null +++ b/lib/asn1/test/testFragmented.erl @@ -0,0 +1,42 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2013. 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 +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% +%% +-module(testFragmented). + +-export([main/1]). + +main(_Erule) -> + roundtrip('PDU', {'PDU',1,false,["abc","def"]}), + B256 = lists:seq(0, 255), + K1 = lists:duplicate(4, B256), + K8 = binary_to_list(iolist_to_binary(lists:duplicate(8, K1))), + roundtrip('PDU', {'PDU',1,false,[K8,K8]}), + roundtrip('PDU', {'PDU',1,false,[K8,K8,K8,K8]}), + roundtrip('PDU', {'PDU',1,false,[K8,K8,K8,K8,K8,K8]}), + roundtrip('PDU', {'PDU',1,false,[K8,K8,K8,K8,K8,K8,K8,K8]}), + roundtrip('PDU', {'PDU',1,false,[K8,K8,K8,K8,K8,K8,K8,K8, + K8,K8,K8,K8,K8,K8]}), + roundtrip('PDU', {'PDU',1,false,[K8,K8,K8,K8,K8,K8,K8,K8, + K8,K8,K8,K8,K8,K8,K8,K8]}), + ok. + +roundtrip(T, V) -> + {ok,E} = 'Fragmented':encode(T, V), + {ok,V} = 'Fragmented':decode(T, E), + ok. diff --git a/lib/asn1/test/testInfObj.erl b/lib/asn1/test/testInfObj.erl index c7b19a0cbb..76f216fdad 100644 --- a/lib/asn1/test/testInfObj.erl +++ b/lib/asn1/test/testInfObj.erl @@ -59,13 +59,73 @@ main(_Erule) -> {'ConstructedPdu',2,{'CONSTRUCTED-DEFAULT_Type',999,false}}), roundtrip('InfObj', 'ConstructedPdu', {'ConstructedPdu',3,true}), + {'ConstructedPdu',4,{_,42,<<13:7>>}} = + enc_dec('InfObj', 'ConstructedPdu', + {'ConstructedPdu',4,{'',42,<<13:7>>}}), + roundtrip('InfObj', 'ConstructedPdu', + {'ConstructedPdu',5,{i,-250138}}), + roundtrip('InfObj', 'ConstructedPdu', + {'ConstructedPdu',5,{b,<<13456:15>>}}), + roundtrip('InfObj', 'ConstructedPdu', + {'ConstructedPdu',6,[]}), + roundtrip('InfObj', 'ConstructedPdu', + {'ConstructedPdu',6,[10,7,16,1,5,13,12]}), + roundtrip('InfObj', 'ConstructedPdu', + {'ConstructedPdu',7,[]}), + roundtrip('InfObj', 'ConstructedPdu', + {'ConstructedPdu',7,[64,1,19,17,35]}), + + roundtrip('InfObj', 'ConstructedSet', + {'ConstructedSet',1,{'CONSTRUCTED-DEFAULT_Type',-2001,true}}), + roundtrip('InfObj', 'ConstructedSet', + {'ConstructedSet',2,{'CONSTRUCTED-DEFAULT_Type',999,false}}), + roundtrip('InfObj', 'ConstructedSet', + {'ConstructedSet',3,true}), + {'ConstructedSet',4,{_,42,<<13:7>>}} = + enc_dec('InfObj', 'ConstructedSet', + {'ConstructedSet',4,{'',42,<<13:7>>}}), + roundtrip('InfObj', 'ConstructedSet', + {'ConstructedSet',5,{i,-250138}}), + roundtrip('InfObj', 'ConstructedSet', + {'ConstructedSet',5,{b,<<13456:15>>}}), + roundtrip('InfObj', 'ConstructedSet', + {'ConstructedSet',6,[]}), + roundtrip('InfObj', 'ConstructedSet', + {'ConstructedSet',6,[10,7,16,1,5,13,12]}), + roundtrip('InfObj', 'ConstructedSet', + {'ConstructedSet',7,[]}), + roundtrip('InfObj', 'ConstructedSet', + {'ConstructedSet',7,[64,1,19,17,35]}), roundtrip('InfObj', 'Seq2', {'Seq2',42,[true,false,false,true], - [false,true,false]}). + [false,true,false]}), + + roundtrip('InfObj', 'OptionalInSeq', {'OptionalInSeq',3,true}), + roundtrip('InfObj', 'OptionalInSeq', {'OptionalInSeq',3,asn1_NOVALUE}), + + roundtrip('InfObj', 'DefaultInSeq', {'DefaultInSeq',3,false}), + roundtrip('InfObj', 'DefaultInSeq', {'DefaultInSeq',3,true}), + {'DefaultInSeq',3,true} = + enc_dec('InfObj', 'DefaultInSeq', {'DefaultInSeq',3,asn1_DEFAULT}), + roundtrip('InfObj', 'Multiple-Optionals', + {'Multiple-Optionals',1,42,true,"abc"}), + roundtrip('InfObj', 'Multiple-Optionals', + {'Multiple-Optionals',1,asn1_NOVALUE,true,"abc"}), + roundtrip('InfObj', 'Multiple-Optionals', + {'Multiple-Optionals',1,42,asn1_NOVALUE,"abc"}), + roundtrip('InfObj', 'Multiple-Optionals', + {'Multiple-Optionals',1,42,true,asn1_NOVALUE}), + roundtrip('InfObj', 'Multiple-Optionals', + {'Multiple-Optionals',1,asn1_NOVALUE,asn1_NOVALUE,asn1_NOVALUE}). roundtrip(M, T, V) -> {ok,Enc} = M:encode(T, V), {ok,V} = M:decode(T, Enc), ok. + +enc_dec(M, T, V0) -> + {ok,Enc} = M:encode(T, V0), + {ok,V} = M:decode(T, Enc), + V. diff --git a/lib/asn1/test/testParameterizedInfObj.erl b/lib/asn1/test/testParameterizedInfObj.erl index 1dfa52f401..02847e502b 100644 --- a/lib/asn1/test/testParameterizedInfObj.erl +++ b/lib/asn1/test/testParameterizedInfObj.erl @@ -86,8 +86,18 @@ param(Erule) -> asn1_wrapper:encode('Param','OS1',[1,2,3,4]) end, + roundtrip('Scl', {'Scl',42,{a,9738654}}), + roundtrip('Scl', {'Scl',42,{b,false}}), + roundtrip('Scl', {'Scl',42,{b,true}}), + + ok. + +roundtrip(T, V) -> + {ok,Enc} = 'Param':encode(T, V), + {ok,V} = 'Param':decode(T, Enc), ok. + ranap(_Erule) -> PIEVal2 = [{'ProtocolIE-Field',4,ignore,{radioNetwork,'rab-pre-empted'}}], ?line Val2 = diff --git a/lib/asn1/test/testPrimStrings.erl b/lib/asn1/test/testPrimStrings.erl index e2322c92a9..1762e34599 100644 --- a/lib/asn1/test/testPrimStrings.erl +++ b/lib/asn1/test/testPrimStrings.erl @@ -28,9 +28,46 @@ -export([bmp_string/1]). -export([times/1]). -export([utf8_string/1]). +-export([fragmented/1]). -include_lib("test_server/include/test_server.hrl"). +fragmented(Rules) -> + Lens = fragmented_lengths(), + fragmented_octet_string(Rules, Lens), + case Rules of + per -> + %% NYI. + ok; + _ -> + fragmented_strings(Lens) + end. + +fragmented_strings(Lens) -> + Types = ['Ns','Ps','Ps11','Vis','IA5'], + [fragmented_strings(Len, Types) || Len <- Lens], + ok. + +fragmented_strings(Len, Types) -> + Str = make_ns_value(Len), + [roundtrip(Type, Str) || Type <- Types], + ok. + +make_ns_value(0) -> []; +make_ns_value(N) -> [($0 - 1) + random:uniform(10)|make_ns_value(N-1)]. + +fragmented_lengths() -> + K16 = 1 bsl 14, + K32 = K16 + K16, + K48 = K32 + K16, + K64 = K48 + K16, + [0,1,14,15,16,17,127,128, + K16-1,K16,K16+1,K16+(1 bsl 7)-1,K16+(1 bsl 7),K16+(1 bsl 7)+1, + K32-1,K32,K32+1,K32+(1 bsl 7)-1,K32+(1 bsl 7),K32+(1 bsl 7)+1, + K48-1,K48,K48+1,K48+(1 bsl 7)-1,K48+(1 bsl 7),K48+(1 bsl 7)+1, + K64-1,K64,K64+1,K64+(1 bsl 7)-1,K64+(1 bsl 7),K64+(1 bsl 7)+1, + K64+K16-1,K64+K16,K64+K16+1]. + bit_string(Rules) -> %%========================================================== @@ -311,8 +348,6 @@ octet_string(Rules) -> ok end, - fragmented_octet_string(Rules), - S255 = lists:seq(1, 255), Strings = {type,true,"","1","12","345",true, S255,[$a|S255],[$a,$b|S255],397}, @@ -324,17 +359,7 @@ octet_string(Rules) -> p_roundtrip('OsVarStringsExt', ShortenedStrings), ok. -fragmented_octet_string(Erules) -> - K16 = 1 bsl 14, - K32 = K16 + K16, - K48 = K32 + K16, - K64 = K48 + K16, - Lens = [0,1,14,15,16,17,127,128, - K16-1,K16,K16+1,K16+(1 bsl 7)-1,K16+(1 bsl 7),K16+(1 bsl 7)+1, - K32-1,K32,K32+1,K32+(1 bsl 7)-1,K32+(1 bsl 7),K32+(1 bsl 7)+1, - K48-1,K48,K48+1,K48+(1 bsl 7)-1,K48+(1 bsl 7),K48+(1 bsl 7)+1, - K64-1,K64,K64+1,K64+(1 bsl 7)-1,K64+(1 bsl 7),K64+(1 bsl 7)+1, - K64+K16-1,K64+K16,K64+K16+1], +fragmented_octet_string(Erules, Lens) -> Types = ['Os','OsFrag','OsFragExt'], [fragmented_octet_string(Erules, Types, L) || L <- Lens], fragmented_octet_string(Erules, ['FixedOs65536'], 65536), diff --git a/lib/asn1/test/testSeqOf.erl b/lib/asn1/test/testSeqOf.erl index db537b1478..c50cc27f6f 100644 --- a/lib/asn1/test/testSeqOf.erl +++ b/lib/asn1/test/testSeqOf.erl @@ -83,6 +83,32 @@ main(_Rules) -> roundtrip('Seq4', #'Seq4'{seq43=SeqIn3}, #'Seq4'{seq41=[],seq42=[], seq43=SeqIn3}), + + roundtrip('Seq5', {'Seq5',true,[],77}), + roundtrip('Seq5', {'Seq5',true,[""],77}), + roundtrip('Seq5', {'Seq5',true,["a"],77}), + roundtrip('Seq5', {'Seq5',true,["ab"],77}), + roundtrip('Seq5', {'Seq5',true,["abc"],77}), + + roundtrip('Seq6', {'Seq6',[],[],101}), + roundtrip('Seq6', {'Seq6',[],[7],101}), + roundtrip('Seq6', {'Seq6',[],[1,7],101}), + roundtrip('Seq6', {'Seq6',[1],[],101}), + roundtrip('Seq6', {'Seq6',[2],[7],101}), + roundtrip('Seq6', {'Seq6',[3],[1,7],101}), + + roundtrip('Seq8', {'Seq8',[],37}), + + roundtrip('Seq9', {'Seq9',true,[],97}), + roundtrip('Seq9', {'Seq9',true,[""],97}), + roundtrip('Seq9', {'Seq9',true,["x"],97}), + roundtrip('Seq9', {'Seq9',true,["xy"],97}), + roundtrip('Seq9', {'Seq9',true,["xyz"],97}), + + roundtrip('Seq10', {'Seq10',true,[""],97}), + roundtrip('Seq10', {'Seq10',true,["a"],97}), + roundtrip('Seq10', {'Seq10',true,["a","b"],97}), + roundtrip('Seq10', {'Seq10',true,["a","b","c"],97}), roundtrip('SeqEmp', #'SeqEmp'{seq1=[#'Empty'{}]}), diff --git a/lib/common_test/src/ct_hooks.erl b/lib/common_test/src/ct_hooks.erl index 3d87a82e24..e845e9e908 100644 --- a/lib/common_test/src/ct_hooks.erl +++ b/lib/common_test/src/ct_hooks.erl @@ -50,9 +50,8 @@ -spec init(State :: term()) -> ok | {fail, Reason :: term()}. init(Opts) -> - call(get_new_hooks(Opts, undefined) ++ get_builtin_hooks(Opts), + call(get_builtin_hooks(Opts) ++ get_new_hooks(Opts, undefined), ok, init, []). - %% @doc Called after all suites are done. -spec terminate(Hooks :: term()) -> @@ -276,8 +275,10 @@ get_new_hooks(Config, Fun) -> end, get_new_hooks(Config)). get_new_hooks(Config) when is_list(Config) -> - lists:flatmap(fun({?config_name, HookConfigs}) -> + lists:flatmap(fun({?config_name, HookConfigs}) when is_list(HookConfigs) -> HookConfigs; + ({?config_name, HookConfig}) when is_atom(HookConfig) -> + [HookConfig]; (_) -> [] end, Config); diff --git a/lib/common_test/src/ct_logs.erl b/lib/common_test/src/ct_logs.erl index bd37b690b6..1a6e4d31a8 100644 --- a/lib/common_test/src/ct_logs.erl +++ b/lib/common_test/src/ct_logs.erl @@ -61,6 +61,7 @@ -define(index_name, "index.html"). -define(totals_name, "totals.info"). -define(log_cache_name, "ct_log_cache"). +-define(misc_io_log, "misc_io.log.html"). -define(table_color1,"#ADD8E6"). -define(table_color2,"#E4F0FE"). @@ -523,7 +524,7 @@ int_footer() -> div_header(Class) -> div_header(Class,"User"). div_header(Class,Printer) -> - "<div class=\"" ++ atom_to_list(Class) ++ "\"><b>*** " ++ Printer ++ + "\n<div class=\"" ++ atom_to_list(Class) ++ "\"><b>*** " ++ Printer ++ " " ++ log_timestamp(now()) ++ " ***</b>". div_footer() -> "</div>". @@ -617,6 +618,34 @@ logger(Parent, Mode, Verbosity) -> end end end, + + test_server_io:start_link(), + MiscIoName = filename:join(Dir, ?misc_io_log), + {ok,MiscIoFd} = file:open(MiscIoName, + [write,{encoding,utf8}]), + test_server_io:set_fd(unexpected_io, MiscIoFd), + + {MiscIoHeader,MiscIoFooter} = + case get_ts_html_wrapper("Pre/post-test I/O log", Dir, false, + Dir, undefined, utf8) of + {basic_html,UH,UF} -> + {UH,UF}; + {xhtml,UH,UF} -> + {UH,UF} + end, + io:put_chars(MiscIoFd, + [MiscIoHeader, + "<a name=\"pretest\"></a>\n", + xhtml("<br>\n<h2>Pre-test Log</h2>", + "<br />\n<h3>PRE-TEST LOG</h3>"), + "\n<pre>\n"]), + MiscIoDivider = + "\n<a name=\"posttest\"></a>\n"++ + xhtml("</pre>\n<br><h2>Post-test Log</h2>\n<pre>\n", + "</pre>\n<br />\n<h3>POST-TEST LOG</h3>\n<pre>\n"), + ct_util:set_testdata_async({misc_io_log,{filename:absname(MiscIoName), + MiscIoDivider,MiscIoFooter}}), + ct_event:notify(#event{name=start_logging,node=node(), data=AbsDir}), make_all_runs_index(start), @@ -627,7 +656,7 @@ logger(Parent, Mode, Verbosity) -> end, file:set_cwd(Dir), make_last_run_index(Time), - CtLogFd = open_ctlog(), + CtLogFd = open_ctlog(?misc_io_log), io:format(CtLogFd,int_header()++int_footer(), [log_timestamp(now()),"Common Test Logger started"]), Parent ! {started,self(),{Time,filename:absname("")}}, @@ -922,7 +951,7 @@ set_evmgr_gl(GL) -> EvMgrPid -> group_leader(GL,EvMgrPid) end. -open_ctlog() -> +open_ctlog(MiscIoName) -> {ok,Fd} = file:open(?ct_log_name,[write,{encoding,utf8}]), io:format(Fd, header("Common Test Framework Log", {[],[1,2],[]}), []), case file:consult(ct_run:variables_file_name("../")) of @@ -937,10 +966,21 @@ open_ctlog() -> "No configuration found for test!!\n", [Variables,Reason]) end, + io:format(Fd, + xhtml("<br><br><h2>Pre/post-test I/O Log</h2>\n", + "<br /><br />\n<h4>PRE/POST TEST I/O LOG</h4>\n"), []), + io:format(Fd, + "\n<ul>\n" + "<li><a href=\"~ts#pretest\">" + "View I/O logged before the test run</a></li>\n" + "<li><a href=\"~ts#posttest\">" + "View I/O logged after the test run</a></li>\n</ul>\n", + [MiscIoName,MiscIoName]), + print_style(Fd,undefined), io:format(Fd, - xhtml("<br><br><h2>Progress Log</h2>\n<pre>\n", - "<br /><br /><h4>PROGRESS LOG</h4>\n<pre>\n"), []), + xhtml("<br><h2>Progress Log</h2>\n<pre>\n", + "<br />\n<h4>PROGRESS LOG</h4>\n<pre>\n"), []), Fd. print_style(Fd,undefined) -> @@ -2856,6 +2896,9 @@ make_relative1(DirTs, CwdTs) -> %%% @doc %%% get_ts_html_wrapper(TestName, PrintLabel, Cwd, TableCols, Encoding) -> + get_ts_html_wrapper(TestName, undefined, PrintLabel, Cwd, TableCols, Encoding). + +get_ts_html_wrapper(TestName, Logdir, PrintLabel, Cwd, TableCols, Encoding) -> TestName1 = if is_list(TestName) -> lists:flatten(TestName); true -> @@ -2876,7 +2919,12 @@ get_ts_html_wrapper(TestName, PrintLabel, Cwd, TableCols, Encoding) -> end end, CTPath = code:lib_dir(common_test), - {ok,CtLogdir} = get_log_dir(true), + + {ok,CtLogdir} = + if Logdir == undefined -> get_log_dir(true); + true -> {ok,Logdir} + end, + AllRuns = make_relative(filename:join(filename:dirname(CtLogdir), ?all_runs_name), Cwd), TestIndex = make_relative(filename:join(filename:dirname(CtLogdir), @@ -3074,16 +3122,8 @@ unexpected_io(Pid,ct_internal,_Importance,List,State) -> IoFun = create_io_fun(Pid,State), io:format(State#logger_state.ct_log_fd, "~ts", [lists:foldl(IoFun, [], List)]); -unexpected_io(Pid,Category,Importance,List,State) -> +unexpected_io(Pid,_Category,_Importance,List,State) -> IoFun = create_io_fun(Pid,State), Data = io_lib:format("~ts", [lists:foldl(IoFun, [], List)]), - %% if unexpected io comes in during startup or shutdown, test_server - %% might not be running - if so (noproc exit), simply print to - %% stdout instead (will result in double printouts when pal is used) - try test_server_io:print_unexpected(Data) of - _ -> - ok - catch - _:{noproc,_} -> tc_print(Category,Importance,Data,[]); - _:Reason -> exit(Reason) - end. + test_server_io:print_unexpected(Data), + ok. diff --git a/lib/common_test/src/ct_run.erl b/lib/common_test/src/ct_run.erl index 266ca73417..7c797be03e 100644 --- a/lib/common_test/src/ct_run.erl +++ b/lib/common_test/src/ct_run.erl @@ -1883,7 +1883,7 @@ verify_suites(TestSuites) -> atom_to_list( Suite)), io:format(user, - "Suite ~w not found" + "Suite ~w not found " "in directory ~ts~n", [Suite,TestDir]), {Found,[{DS,[Name]}|NotFound]} diff --git a/lib/common_test/src/ct_util.erl b/lib/common_test/src/ct_util.erl index abda87c2cd..bcc4caa62e 100644 --- a/lib/common_test/src/ct_util.erl +++ b/lib/common_test/src/ct_util.erl @@ -187,6 +187,7 @@ do_start(Parent, Mode, LogDir, Verbosity) -> false -> ok end, + {StartTime,TestLogDir} = ct_logs:init(Mode, Verbosity), ct_event:notify(#event{name=test_start, @@ -198,12 +199,26 @@ do_start(Parent, Mode, LogDir, Verbosity) -> ok -> Parent ! {self(),started}; {fail,CTHReason} -> - ct_logs:tc_print('Suite Callback',CTHReason,[]), + ErrorInfo = if is_atom(CTHReason) -> + io_lib:format("{~p,~p}", + [CTHReason, + erlang:get_stacktrace()]); + true -> + CTHReason + end, + ct_logs:tc_print('Suite Callback',ErrorInfo,[]), self() ! {{stop,{self(),{user_error,CTHReason}}}, {Parent,make_ref()}} catch _:CTHReason -> - ct_logs:tc_print('Suite Callback',CTHReason,[]), + ErrorInfo = if is_atom(CTHReason) -> + io_lib:format("{~p,~p}", + [CTHReason, + erlang:get_stacktrace()]); + true -> + CTHReason + end, + ct_logs:tc_print('Suite Callback',ErrorInfo,[]), self() ! {{stop,{self(),{user_error,CTHReason}}}, {Parent,make_ref()}} end, @@ -392,19 +407,38 @@ loop(Mode,TestData,StartDir) -> return(From,StartDir), loop(From,TestData,StartDir); {{stop,Info},From} -> + test_server_io:reset_state(), + {MiscIoName,MiscIoDivider,MiscIoFooter} = + proplists:get_value(misc_io_log,TestData), + {ok,MiscIoFd} = file:open(MiscIoName, + [append,{encoding,utf8}]), + io:put_chars(MiscIoFd, MiscIoDivider), + test_server_io:set_fd(unexpected_io, MiscIoFd), + Time = calendar:local_time(), ct_event:sync_notify(#event{name=test_done, node=node(), data=Time}), - Callbacks = ets:lookup_element(?suite_table, - ct_hooks, - #suite_data.value), + Callbacks = + try ets:lookup_element(?suite_table, + ct_hooks, + #suite_data.value) of + CTHMods -> CTHMods + catch + %% this is because ct_util failed in init + error:badarg -> [] + end, ct_hooks:terminate(Callbacks), close_connections(ets:tab2list(?conn_table)), ets:delete(?conn_table), ets:delete(?board_table), ets:delete(?suite_table), ets:delete(?verbosity_table), + + io:put_chars(MiscIoFd, "\n</pre>\n"++MiscIoFooter), + test_server_io:stop([unexpected_io]), + test_server_io:finish(), + ct_logs:close(Info, StartDir), ct_event:stop(), ct_config:stop(), @@ -679,8 +713,14 @@ reset_silent_connections() -> %%% @see ct stop(Info) -> case whereis(ct_util_server) of - undefined -> ok; - _ -> call({stop,Info}) + undefined -> + ok; + CtUtilPid -> + Ref = monitor(process, CtUtilPid), + call({stop,Info}), + receive + {'DOWN',Ref,_,_,_} -> ok + end end. %%%----------------------------------------------------------------- diff --git a/lib/common_test/src/cth_log_redirect.erl b/lib/common_test/src/cth_log_redirect.erl index 958b7a94c7..11af1aa346 100644 --- a/lib/common_test/src/cth_log_redirect.erl +++ b/lib/common_test/src/cth_log_redirect.erl @@ -25,16 +25,29 @@ %% CTH Callbacks --export([id/1, init/2, post_init_per_group/4, pre_end_per_group/3, - post_end_per_testcase/4]). +-export([id/1, init/2, + pre_init_per_suite/3, pre_end_per_suite/3, post_end_per_suite/4, + pre_init_per_group/3, post_init_per_group/4, + pre_end_per_group/3, post_end_per_group/4, + pre_init_per_testcase/3, post_end_per_testcase/4]). %% Event handler Callbacks -export([init/1, handle_event/2, handle_call/2, handle_info/2, terminate/1]). +%% Other +-export([handle_remote_events/1]). + -include("ct.hrl"). +-record(eh_state, {log_func, + curr_suite, + curr_group, + curr_func, + parallel_tcs = false, + handle_remote_events = false}). + id(_Opts) -> ?MODULE. @@ -42,36 +55,62 @@ init(?MODULE, _Opts) -> error_logger:add_report_handler(?MODULE), tc_log_async. +pre_init_per_suite(Suite, Config, State) -> + set_curr_func({Suite,init_per_suite}, Config), + {Config, State}. + +pre_end_per_suite(Suite, Config, State) -> + set_curr_func({Suite,end_per_suite}, Config), + {Config, State}. + +post_end_per_suite(_Suite, Config, Return, State) -> + set_curr_func(undefined, Config), + {Return, State}. + +pre_init_per_group(Group, Config, State) -> + set_curr_func({group,Group,init_per_group}, Config), + {Config, State}. + post_init_per_group(Group, Config, Result, tc_log_async) -> case lists:member(parallel,proplists:get_value( tc_group_properties,Config,[])) of true -> - {Result, {set_log_func(ct_log),Group}}; + {Result, {set_log_func(tc_log),Group}}; false -> {Result, tc_log_async} end; post_init_per_group(_Group, _Config, Result, State) -> {Result, State}. +pre_init_per_testcase(TC, Config, State) -> + set_curr_func(TC, Config), + {Config, State}. + post_end_per_testcase(_TC, _Config, Result, State) -> %% Make sure that the event queue is flushed %% before ending this test case. gen_event:call(error_logger, ?MODULE, flush, 300000), {Result, State}. -pre_end_per_group(Group, Config, {ct_log, Group}) -> +pre_end_per_group(Group, Config, {tc_log, Group}) -> + set_curr_func({group,Group,end_per_group}, Config), {Config, set_log_func(tc_log_async)}; -pre_end_per_group(_Group, Config, State) -> +pre_end_per_group(Group, Config, State) -> + set_curr_func({group,Group,end_per_group}, Config), {Config, State}. +post_end_per_group(_Group, Config, Return, State) -> + set_curr_func({group,undefined}, Config), + {Return, State}. %% Copied and modified from sasl_report_tty_h.erl init(_Type) -> - {ok, tc_log_async}. + {ok, #eh_state{log_func = tc_log_async}}. -handle_event({_Type, GL, _Msg}, State) when node(GL) /= node() -> +handle_event({_Type,GL,_Msg}, #eh_state{handle_remote_events = false} = State) + when node(GL) /= node() -> {ok, State}; -handle_event(Event, LogFunc) -> +handle_event(Event, #eh_state{log_func = LogFunc} = State) -> case lists:keyfind(sasl, 1, application:which_applications()) of false -> sasl_not_started; @@ -80,7 +119,8 @@ handle_event(Event, LogFunc) -> SReport = sasl_report:format_report(group_leader(), ErrLogType, tag_event(Event)), if is_list(SReport) -> - ct_logs:LogFunc(sasl, ?STD_IMPORTANCE, "System", SReport, []); + SaslHeader = format_header(State), + ct_logs:LogFunc(sasl, ?STD_IMPORTANCE, SaslHeader, SReport, []); true -> %% Report is an atom if no logging is to be done ignore end @@ -88,20 +128,50 @@ handle_event(Event, LogFunc) -> EReport = error_logger_tty_h:write_event( tag_event(Event),io_lib), if is_list(EReport) -> - ct_logs:LogFunc(error_logger, ?STD_IMPORTANCE, "System", EReport, []); + ErrHeader = format_header(State), + ct_logs:LogFunc(error_logger, ?STD_IMPORTANCE, ErrHeader, EReport, []); true -> %% Report is an atom if no logging is to be done ignore end, - {ok, LogFunc}. + {ok, State}. handle_info(_,State) -> {ok, State}. handle_call(flush,State) -> {ok, ok, State}; -handle_call({set_logfunc,NewLogFunc},_) -> - {ok, NewLogFunc, NewLogFunc}; -handle_call(_Query, _State) -> {error, bad_query}. + +handle_call({set_curr_func,{group,Group,Conf},Config}, State) -> + Parallel = case proplists:get_value(tc_group_properties, Config) of + undefined -> false; + Props -> lists:member(parallel, Props) + end, + {ok, ok, State#eh_state{curr_group = Group, + curr_func = Conf, + parallel_tcs = Parallel}}; +handle_call({set_curr_func,{group,undefined},_Config}, State) -> + {ok, ok, State#eh_state{curr_group = undefined, + curr_func = undefined, + parallel_tcs = false}}; +handle_call({set_curr_func,{Suite,Conf},_Config}, State) -> + {ok, ok, State#eh_state{curr_suite = Suite, + curr_func = Conf, + parallel_tcs = false}}; +handle_call({set_curr_func,undefined,_Config}, State) -> + {ok, ok, State#eh_state{curr_suite = undefined, + curr_func = undefined, + parallel_tcs = false}}; +handle_call({set_curr_func,TC,_Config}, State) -> + {ok, ok, State#eh_state{curr_func = TC}}; + +handle_call({set_logfunc,NewLogFunc}, State) -> + {ok, NewLogFunc, State#eh_state{log_func = NewLogFunc}}; + +handle_call({handle_remote_events,Bool}, State) -> + {ok, ok, State#eh_state{handle_remote_events = Bool}}; + +handle_call(_Query, _State) -> + {error, bad_query}. terminate(_State) -> error_logger:delete_report_handler(?MODULE), @@ -110,5 +180,48 @@ terminate(_State) -> tag_event(Event) -> {calendar:local_time(), Event}. +set_curr_func(CurrFunc, Config) -> + gen_event:call(error_logger, ?MODULE, {set_curr_func, CurrFunc, Config}). + set_log_func(Func) -> gen_event:call(error_logger, ?MODULE, {set_logfunc, Func}). + +handle_remote_events(Bool) -> + gen_event:call(error_logger, ?MODULE, {handle_remote_events, Bool}). + +%%%----------------------------------------------------------------- + +format_header(#eh_state{curr_suite = undefined, + curr_group = undefined, + curr_func = undefined}) -> + io_lib:format("System report", []); + +format_header(#eh_state{curr_suite = Suite, + curr_group = undefined, + curr_func = undefined}) -> + io_lib:format("System report during ~w", [Suite]); + +format_header(#eh_state{curr_suite = Suite, + curr_group = undefined, + curr_func = TcOrConf}) -> + io_lib:format("System report during ~w:~w/1", + [Suite,TcOrConf]); + +format_header(#eh_state{curr_suite = Suite, + curr_group = Group, + curr_func = Conf}) when Conf == init_per_group; + Conf == end_per_group -> + io_lib:format("System report during ~w:~w/2 for ~w", + [Suite,Conf,Group]); + +format_header(#eh_state{curr_suite = Suite, + curr_group = Group, + parallel_tcs = true}) -> + io_lib:format("System report during ~w in ~w", + [Group,Suite]); + +format_header(#eh_state{curr_suite = Suite, + curr_group = Group, + curr_func = TC}) -> + io_lib:format("System report during ~w:~w/1 in ~w", + [Suite,TC,Group]). diff --git a/lib/common_test/test/Makefile b/lib/common_test/test/Makefile index 9d2edcd653..085f19d023 100644 --- a/lib/common_test/test/Makefile +++ b/lib/common_test/test/Makefile @@ -51,6 +51,7 @@ MODULES= \ ct_master_SUITE \ ct_misc_1_SUITE \ ct_hooks_SUITE \ + ct_pre_post_test_io_SUITE \ ct_netconfc_SUITE \ ct_basic_html_SUITE \ ct_auto_compile_SUITE \ diff --git a/lib/common_test/test/ct_gen_conn_SUITE_data/proto.erl b/lib/common_test/test/ct_gen_conn_SUITE_data/proto.erl index 8fcd35e0a4..1d08ce167b 100644 --- a/lib/common_test/test/ct_gen_conn_SUITE_data/proto.erl +++ b/lib/common_test/test/ct_gen_conn_SUITE_data/proto.erl @@ -1,10 +1,21 @@ -%%% @author Peter Andersson <[email protected]> -%%% @copyright (C) 2013, Peter Andersson -%%% @doc -%%% -%%% @end -%%% Created : 24 May 2013 by Peter Andersson <[email protected]> - +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2012. 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 +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% -module(proto). -compile(export_all). diff --git a/lib/common_test/test/ct_hooks_SUITE.erl b/lib/common_test/test/ct_hooks_SUITE.erl index 796a0832d7..596bfe3ff0 100644 --- a/lib/common_test/test/ct_hooks_SUITE.erl +++ b/lib/common_test/test/ct_hooks_SUITE.erl @@ -84,7 +84,7 @@ all(suite) -> skip_post_suite_cth, recover_post_suite_cth, update_config_cth, state_update_cth, options_cth, same_id_cth, fail_n_skip_with_minimal_cth, prio_cth, no_config, - data_dir + data_dir, cth_log ] ). @@ -222,7 +222,32 @@ data_dir(Config) when is_list(Config) -> do_test(data_dir, "ct_data_dir_SUITE.erl", [verify_data_dir_cth],Config). - +cth_log(Config) when is_list(Config) -> + %% test that cth_log_redirect writes properly to + %% unexpected I/O log + StartOpts = do_test(cth_log, "cth_log_SUITE.erl", [], Config), + Logdir = proplists:get_value(logdir, StartOpts), + UnexpIoLogs = + filelib:wildcard( + filename:join(Logdir, + "ct_run*/cth.tests*/run*/unexpected_io.log.html")), + lists:foreach( + fun(UnexpIoLog) -> + {ok,Bin} = file:read_file(UnexpIoLog), + Ts = string:tokens(binary_to_list(Bin),[$\n]), + Matches = lists:foldl(fun([$=,$E,$R,$R,$O,$R|_], N) -> + N+1; + ([$L,$o,$g,$g,$e,$r|_], N) -> + N+1; + (_, N) -> N + end, 0, Ts), + ct:pal("~p matches in ~tp", [Matches,UnexpIoLog]), + if Matches > 10 -> ok; + true -> exit({no_unexpected_io_found,UnexpIoLog}) + end + end, UnexpIoLogs), + ok. + %%%----------------------------------------------------------------- %%% HELP FUNCTIONS @@ -251,7 +276,8 @@ do_test(Tag, SuiteWildCard, CTHs, Config, Res, EC) -> Opts), TestEvents = events_to_check(Tag, EC), - ok = ct_test_support:verify_events(TestEvents, Events, Config). + ok = ct_test_support:verify_events(TestEvents, Events, Config), + Opts. setup(Test, Config) -> Opts0 = ct_test_support:get_opts(Config), @@ -1187,6 +1213,23 @@ test_events(data_dir) -> {?eh,stop_logging,[]} ]; +test_events(cth_log) -> + [{?eh,start_logging,{'DEF','RUNDIR'}}, + {?eh,test_start,{'DEF',{'START_TIME','LOGDIR'}}}, + {?eh,tc_start,{cth_log_SUITE,init_per_suite}}, + + {parallel, + [{?eh,tc_start,{ct_framework,{init_per_group,g1,[parallel]}}}, + {?eh,tc_done,{ct_framework,{init_per_group,g1,[parallel]},ok}}, + {?eh,test_stats,{30,0,{0,0}}}, + {?eh,tc_start,{ct_framework,{end_per_group,g1,[parallel]}}}, + {?eh,tc_done,{ct_framework,{end_per_group,g1,[parallel]},ok}}]}, + + {?eh,tc_done,{cth_log_SUITE,end_per_suite,ok}}, + {?eh,test_done,{'DEF','STOP_TIME'}}, + {?eh,stop_logging,[]} + ]; + test_events(ok) -> ok. diff --git a/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/cth_log_SUITE.erl b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/cth_log_SUITE.erl new file mode 100644 index 0000000000..18dd07e87e --- /dev/null +++ b/lib/common_test/test/ct_hooks_SUITE_data/cth/tests/cth_log_SUITE.erl @@ -0,0 +1,124 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2010-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 +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% + +-module(cth_log_SUITE). + +-compile(export_all). + +-include_lib("common_test/include/ct.hrl"). + +%%-------------------------------------------------------------------- +%% @spec suite() -> Info +%% Info = [tuple()] +%% @end +%%-------------------------------------------------------------------- +suite() -> + [{timetrap,{seconds,30}}]. + +%%-------------------------------------------------------------------- +%% @spec init_per_suite(Config0) -> +%% Config1 | {skip,Reason} | {skip_and_save,Reason,Config1} +%% Config0 = Config1 = [tuple()] +%% Reason = term() +%% @end +%%-------------------------------------------------------------------- +init_per_suite(Config) -> + Gen = spawn(fun() -> gen() end), + [{gen,Gen}|Config]. + +%%-------------------------------------------------------------------- +%% @spec end_per_suite(Config0) -> void() | {save_config,Config1} +%% Config0 = Config1 = [tuple()] +%% @end +%%-------------------------------------------------------------------- +end_per_suite(Config) -> + Gen = proplists:get_value(gen, Config), + exit(Gen, kill), + timer:sleep(100), + ok. + +%%-------------------------------------------------------------------- +%% @spec init_per_testcase(TestCase, Config0) -> +%% Config1 | {skip,Reason} | {skip_and_save,Reason,Config1} +%% TestCase = atom() +%% Config0 = Config1 = [tuple()] +%% Reason = term() +%% @end +%%-------------------------------------------------------------------- +init_per_testcase(_TestCase, Config) -> + Config. + +%%-------------------------------------------------------------------- +%% @spec end_per_testcase(TestCase, Config0) -> +%% void() | {save_config,Config1} | {fail,Reason} +%% TestCase = atom() +%% Config0 = Config1 = [tuple()] +%% Reason = term() +%% @end +%%-------------------------------------------------------------------- +end_per_testcase(_TestCase, _Config) -> + ok. + +%%-------------------------------------------------------------------- +%% @spec groups() -> [Group] +%% Group = {GroupName,Properties,GroupsAndTestCases} +%% GroupName = atom() +%% Properties = [parallel | sequence | Shuffle | {RepeatType,N}] +%% GroupsAndTestCases = [Group | {group,GroupName} | TestCase] +%% TestCase = atom() +%% Shuffle = shuffle | {shuffle,{integer(),integer(),integer()}} +%% RepeatType = repeat | repeat_until_all_ok | repeat_until_all_fail | +%% repeat_until_any_ok | repeat_until_any_fail +%% N = integer() | forever +%% @end +%%-------------------------------------------------------------------- +groups() -> + [{g1,[parallel,{repeat,10}],[tc1,tc2,tc3]}]. + +%%-------------------------------------------------------------------- +%% @spec all() -> GroupsAndTestCases | {skip,Reason} +%% GroupsAndTestCases = [{group,GroupName} | TestCase] +%% GroupName = atom() +%% TestCase = atom() +%% Reason = term() +%% @end +%%-------------------------------------------------------------------- +all() -> + [{group,g1}]. + +tc1(_) -> + ct:sleep(100), + ok. +tc2(_) -> + ct:sleep(100), + ok. +tc3(_) -> + ct:sleep(100), + ok. + +%%%----------------------------------------------------------------- + +gen() -> + gen_loop(1). + +gen_loop(N) -> + ct:log("Logger iteration: ~p", [N]), + error_logger:error_report(N), + ct:sleep(200), + gen_loop(N+1). diff --git a/lib/common_test/test/ct_pre_post_test_io_SUITE.erl b/lib/common_test/test/ct_pre_post_test_io_SUITE.erl new file mode 100644 index 0000000000..84341a0b99 --- /dev/null +++ b/lib/common_test/test/ct_pre_post_test_io_SUITE.erl @@ -0,0 +1,252 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2012. 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 +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% + +%%%------------------------------------------------------------------- +%%% File: ct_pre_post_test_io_SUITE +%%% +%%% Description: +%%% +%%% Test that ct:log/2 printouts and error/progress reports that happen +%%% before or after the test run are saved in the pre/post test IO log. +%%%------------------------------------------------------------------- +-module(ct_pre_post_test_io_SUITE). + +-compile(export_all). + +-include_lib("common_test/include/ct.hrl"). +-include_lib("common_test/include/ct_event.hrl"). + +-define(eh, ct_test_support_eh). + +%%-------------------------------------------------------------------- +%% TEST SERVER CALLBACK FUNCTIONS +%%-------------------------------------------------------------------- + +%%-------------------------------------------------------------------- +%% Description: Since Common Test starts another Test Server +%% instance, the tests need to be performed on a separate node (or +%% there will be clashes with logging processes etc). +%%-------------------------------------------------------------------- +init_per_suite(Config) -> + DataDir = ?config(data_dir, Config), + CTH = filename:join(DataDir, "cth_ctrl.erl"), + ct:pal("Compiling ~p: ~p", + [CTH,compile:file(CTH,[{outdir,DataDir},debug_info])]), + ct_test_support:init_per_suite([{path_dirs,[DataDir]}, + {start_sasl,true} | Config]). + +end_per_suite(Config) -> + ct_test_support:end_per_suite(Config). + +init_per_testcase(TestCase, Config) -> + ct_test_support:init_per_testcase(TestCase, Config). + +end_per_testcase(TestCase, Config) -> + ct_test_support:end_per_testcase(TestCase, Config). + +suite() -> [{ct_hooks,[ts_install_cth]}]. + +all() -> + [ + pre_post_io + ]. + +%%-------------------------------------------------------------------- +%% TEST CASES +%%-------------------------------------------------------------------- + +%%%----------------------------------------------------------------- +%%% +pre_post_io(Config) -> + TC = pre_post_io, + DataDir = ?config(data_dir, Config), + Suite = filename:join(DataDir, "dummy_SUITE"), + {Opts,ERPid} = setup([{suite,Suite},{label,TC},{ct_hooks,[cth_ctrl]}], + Config), + + %%!-------------------------------------------------------------------- + %%! Note that error reports will not start showing up in the pre-test + %%! io log until handle_remote_events has been set to true (see below). + %%! The reason is that the error logger has its group leader on the + %%! test_server node (not the ct node) and cth_log_redirect ignores + %%! events with remote destination until told otherwise. + %%!-------------------------------------------------------------------- + + spawn(fun() -> + %% --- test run 1 --- + ct:sleep(3000), + ct_test_support:ct_rpc({cth_log_redirect, + handle_remote_events, + [true]}, Config), + ct:sleep(2000), + io:format(user, "Starting test run!~n", []), + ct_test_support:ct_rpc({cth_ctrl,proceed,[]}, Config), + ct:sleep(6000), + io:format(user, "Finishing off!~n", []), + ct_test_support:ct_rpc({cth_ctrl,proceed,[]}, Config), + %% --- test run 2 --- + ct:sleep(3000), + ct_test_support:ct_rpc({cth_log_redirect, + handle_remote_events, + [true]}, Config), + ct:sleep(2000), + io:format(user, "Starting test run!~n", []), + ct_test_support:ct_rpc({cth_ctrl,proceed,[]}, Config), + ct:sleep(6000), + io:format(user, "Finishing off!~n", []), + ct_test_support:ct_rpc({cth_ctrl,proceed,[]}, Config) + end), + ct_test_support:run(Opts, Config), + Events = ct_test_support:get_events(ERPid, Config), + ct_test_support:log_events(TC, + reformat(Events, ?eh), + ?config(priv_dir, Config), + Opts), + TestEvents = events_to_check(TC), + ok = ct_test_support:verify_events(TestEvents, Events, Config), + + LogDirs = lists:flatmap(fun({_EH,#event{name=start_logging,data=Dir}}) -> + [Dir]; + (_) -> + [] + end, Events), + PrePostIoFiles = + [filename:join(LogDir, "misc_io.log.html") || LogDir <- LogDirs], + lists:foreach( + fun(PrePostIoFile) -> + ct:log("Reading Pre/Post Test IO Log file: ~ts", [PrePostIoFile]), + {ok,Bin} = file:read_file(PrePostIoFile), + Ts = string:tokens(binary_to_list(Bin),[$\n]), + PrePostIOEntries = + lists:foldl(fun([$L,$o,$g,$g,$e,$r|_], + {pre,PreLogN,PreErrN,0,0}) -> + {pre,PreLogN+1,PreErrN,0,0}; + ([$=,$E,$R,$R,$O,$R|_], + {pre,PreLogN,PreErrN,0,0}) -> + {pre,PreLogN,PreErrN+1,0,0}; + ([_,_,_,_,$P,$O,$S,$T,$-,$T,$E,$S,$T|_], + {pre,PreLogN,PreErrN,0,0}) -> + {post,PreLogN,PreErrN,0,0}; + ([$L,$o,$g,$g,$e,$r|_], + {post,PreLogN,PreErrN,PostLogN,PostErrN}) -> + {post,PreLogN,PreErrN,PostLogN+1,PostErrN}; + ([$=,$E,$R,$R,$O,$R|_], + {post,PreLogN,PreErrN,PostLogN,PostErrN}) -> + {post,PreLogN,PreErrN,PostLogN,PostErrN+1}; + (_, Counters) -> + Counters + end, {pre,0,0,0,0}, Ts), + [_|Counters] = tuple_to_list(PrePostIOEntries), + ct:log("Entries in the Pre/Post Test IO Log: ~p", [Counters]), + case [C || C <- Counters, C < 2] of + [] -> + ok; + _ -> + exit("Not enough entries in the Pre/Post Test IO Log!") + end + end, PrePostIoFiles), + + UnexpIoFiles = + [filelib:wildcard( + filename:join(LogDir, + "*dummy_SUITE.logs/run.*/" + "unexpected_io.log.html")) || LogDir <- LogDirs], + lists:foreach( + fun(UnexpIoFile) -> + ct:log("Reading Unexpected IO Log file: ~ts", [UnexpIoFile]), + {ok,Bin} = file:read_file(UnexpIoFile), + Ts = string:tokens(binary_to_list(Bin),[$\n]), + UnexpIOEntries = + lists:foldl(fun([$L,$o,$g,$g,$e,$r|_], [LogN,ErrN]) -> + [LogN+1,ErrN]; + ([$=,$E,$R,$R,$O,$R|_], [LogN,ErrN]) -> + [LogN,ErrN+1]; + (_, Counters) -> Counters + end, [0,0], Ts), + ct:log("Entries in the Unexpected IO Log: ~p", [UnexpIOEntries]), + case [N || N <- UnexpIOEntries, N < 2] of + [] -> + ok; + _ -> + exit("Not enough entries in the Unexpected IO Log!") + end + end, UnexpIoFiles), + ok. + +%%%----------------------------------------------------------------- +%%% HELP FUNCTIONS +%%%----------------------------------------------------------------- + +setup(Test, Config) -> + Opts0 = ct_test_support:get_opts(Config), + Level = ?config(trace_level, Config), + EvHArgs = [{cbm,ct_test_support},{trace_level,Level}], + Opts = Opts0 ++ [{event_handler,{?eh,EvHArgs}}|Test], + ERPid = ct_test_support:start_event_receiver(Config), + {Opts,ERPid}. + +reformat(Events, EH) -> + ct_test_support:reformat(Events, EH). + +%%%----------------------------------------------------------------- +%%% TEST EVENTS +%%%----------------------------------------------------------------- + +events_to_check(pre_post_io) -> + [ + {?eh,start_logging,{'DEF','RUNDIR'}}, + {?eh,test_start,{'DEF',{'START_TIME','LOGDIR'}}}, + {?eh,start_info,{1,1,7}}, + {?eh,tc_start,{dummy_SUITE,init_per_suite}}, + {?eh,tc_done,{dummy_SUITE,init_per_suite,ok}}, + {parallel, + [{?eh,tc_start,{dummy_SUITE,{init_per_group,g1,[parallel]}}}, + {?eh,tc_done, + {dummy_SUITE,{init_per_group,g1,[parallel]},ok}}, + {?eh,tc_start,{dummy_SUITE,tc1}}, + {?eh,tc_start,{dummy_SUITE,tc2}}, + {?eh,tc_start,{dummy_SUITE,tc3}}, + {?eh,tc_done,{dummy_SUITE,tc2,ok}}, + {?eh,tc_done,{dummy_SUITE,tc1,ok}}, + {?eh,tc_done,{dummy_SUITE,tc3,ok}}, + {?eh,test_stats,{1,0,{0,0}}}, + {?eh,test_stats,{2,0,{0,0}}}, + {?eh,test_stats,{3,0,{0,0}}}, + {?eh,tc_start,{dummy_SUITE,{end_per_group,g1,[parallel]}}}, + {?eh,tc_done,{dummy_SUITE,{end_per_group,g1,[parallel]},ok}}]}, + {?eh,tc_start,{dummy_SUITE,tc1}}, + {?eh,tc_done,{dummy_SUITE,tc1,ok}}, + {?eh,test_stats,{4,0,{0,0}}}, + {?eh,tc_start,{dummy_SUITE,tc2}}, + {?eh,tc_done,{dummy_SUITE,tc2,ok}}, + {?eh,test_stats,{5,0,{0,0}}}, + [{?eh,tc_start,{dummy_SUITE,{init_per_group,g2,[]}}}, + {?eh,tc_done,{dummy_SUITE,{init_per_group,g2,[]},ok}}, + {?eh,tc_start,{dummy_SUITE,tc4}}, + {?eh,tc_done,{dummy_SUITE,tc4,ok}}, + {?eh,test_stats,{6,0,{0,0}}}, + {?eh,tc_start,{dummy_SUITE,tc5}}, + {?eh,tc_done,{dummy_SUITE,tc5,ok}}, + {?eh,test_stats,{7,0,{0,0}}}, + {?eh,tc_start,{dummy_SUITE,{end_per_group,g2,[]}}}, + {?eh,tc_done,{dummy_SUITE,{end_per_group,g2,[]},ok}}], + {?eh,tc_start,{dummy_SUITE,end_per_suite}}, + {?eh,tc_done,{dummy_SUITE,end_per_suite,ok}}, + {?eh,test_done,{'DEF','STOP_TIME'}}, + {?eh,stop_logging,[]}]. diff --git a/lib/common_test/test/ct_pre_post_test_io_SUITE_data/cth_ctrl.erl b/lib/common_test/test/ct_pre_post_test_io_SUITE_data/cth_ctrl.erl new file mode 100644 index 0000000000..a9ea7b14dd --- /dev/null +++ b/lib/common_test/test/ct_pre_post_test_io_SUITE_data/cth_ctrl.erl @@ -0,0 +1,104 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2012. 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 +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% +-module(cth_ctrl). + +-export([proceed/0, + init/2, terminate/1]). + +%%%=================================================================== +%%% API +%%%=================================================================== + +proceed() -> + ?MODULE ! proceed. + +%%-------------------------------------------------------------------- +%% Hook functions +%%-------------------------------------------------------------------- +init(_Id, _Opts) -> + case lists:keyfind(sasl, 1, application:which_applications()) of + false -> + exit(sasl_not_started); + _Else -> + ok + end, + WhoAmI = self(), + DispPid = spawn_link(fun() -> dispatcher(WhoAmI) end), + register(?MODULE, DispPid), + io:format(user, + "~n~n+++ Startup of ~w on ~p finished, " + "call ~w:proceed() to run tests...~n", + [?MODULE,node(),?MODULE]), + start_external_logger(cth_logger), + receive + {?MODULE,proceed} -> ok + after + 10000 -> + ok + end, + {ok,[],ct_last}. + +terminate(_State) -> + io:format(user, + "~n~n+++ Tests finished, call ~w:proceed() to shut down...~n", + [?MODULE]), + receive + {?MODULE,proceed} -> ok + after + 10000 -> + ok + end, + stop_external_logger(cth_logger), + stop_dispatcher(), + ok. + +%%%=================================================================== +%%% Internal functions +%%%=================================================================== + +start_external_logger(Name) -> + case whereis(Name) of + undefined -> ok; + Pid -> exit(Pid, kill) + end, + spawn(fun() -> init_logger(Name) end). + +stop_external_logger(Name) -> + catch exit(whereis(Name), kill). + +init_logger(Name) -> + register(Name, self()), + logger_loop(1). + +logger_loop(N) -> + ct:log("Logger iteration: ~p", [N]), + error_logger:error_report(N), + timer:sleep(250), + logger_loop(N+1). + +%%%----------------------------------------------------------------- + +dispatcher(SendTo) -> + receive Msg -> SendTo ! {?MODULE,Msg} end, + dispatcher(SendTo). + +stop_dispatcher() -> + catch exit(whereis(?MODULE), kill). + + diff --git a/lib/common_test/test/ct_pre_post_test_io_SUITE_data/dummy_SUITE.erl b/lib/common_test/test/ct_pre_post_test_io_SUITE_data/dummy_SUITE.erl new file mode 100644 index 0000000000..ac9c4efd31 --- /dev/null +++ b/lib/common_test/test/ct_pre_post_test_io_SUITE_data/dummy_SUITE.erl @@ -0,0 +1,132 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2012. 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 +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% +-module(dummy_SUITE). + +-compile(export_all). + +-include_lib("common_test/include/ct.hrl"). + +%%-------------------------------------------------------------------- +%% @spec suite() -> Info +%% Info = [tuple()] +%% @end +%%-------------------------------------------------------------------- +suite() -> + [{timetrap,{seconds,30}}]. + +%%-------------------------------------------------------------------- +%% @spec init_per_suite(Config0) -> +%% Config1 | {skip,Reason} | {skip_and_save,Reason,Config1} +%% Config0 = Config1 = [tuple()] +%% Reason = term() +%% @end +%%-------------------------------------------------------------------- +init_per_suite(Config) -> + Config. + +%%-------------------------------------------------------------------- +%% @spec end_per_suite(Config0) -> void() | {save_config,Config1} +%% Config0 = Config1 = [tuple()] +%% @end +%%-------------------------------------------------------------------- +end_per_suite(_Config) -> + ok. + +%%-------------------------------------------------------------------- +%% @spec init_per_group(GroupName, Config0) -> +%% Config1 | {skip,Reason} | {skip_and_save,Reason,Config1} +%% GroupName = atom() +%% Config0 = Config1 = [tuple()] +%% Reason = term() +%% @end +%%-------------------------------------------------------------------- +init_per_group(_GroupName, Config) -> + Config. + +%%-------------------------------------------------------------------- +%% @spec end_per_group(GroupName, Config0) -> +%% void() | {save_config,Config1} +%% GroupName = atom() +%% Config0 = Config1 = [tuple()] +%% @end +%%-------------------------------------------------------------------- +end_per_group(_GroupName, _Config) -> + ok. + +%%-------------------------------------------------------------------- +%% @spec init_per_testcase(TestCase, Config0) -> +%% Config1 | {skip,Reason} | {skip_and_save,Reason,Config1} +%% TestCase = atom() +%% Config0 = Config1 = [tuple()] +%% Reason = term() +%% @end +%%-------------------------------------------------------------------- +init_per_testcase(_TestCase, Config) -> + ct:sleep(500), + Config. + +%%-------------------------------------------------------------------- +%% @spec end_per_testcase(TestCase, Config0) -> +%% void() | {save_config,Config1} | {fail,Reason} +%% TestCase = atom() +%% Config0 = Config1 = [tuple()] +%% Reason = term() +%% @end +%%-------------------------------------------------------------------- +end_per_testcase(_TestCase, _Config) -> + ok. + +%%-------------------------------------------------------------------- +%% @spec groups() -> [Group] +%% Group = {GroupName,Properties,GroupsAndTestCases} +%% GroupName = atom() +%% Properties = [parallel | sequence | Shuffle | {RepeatType,N}] +%% GroupsAndTestCases = [Group | {group,GroupName} | TestCase] +%% TestCase = atom() +%% Shuffle = shuffle | {shuffle,{integer(),integer(),integer()}} +%% RepeatType = repeat | repeat_until_all_ok | repeat_until_all_fail | +%% repeat_until_any_ok | repeat_until_any_fail +%% N = integer() | forever +%% @end +%%-------------------------------------------------------------------- +groups() -> + [{g1,[parallel],[tc1,tc2,tc3]}, + {g2,[],[tc4,tc5]}]. + +%%-------------------------------------------------------------------- +%% @spec all() -> GroupsAndTestCases | {skip,Reason} +%% GroupsAndTestCases = [{group,GroupName} | TestCase] +%% GroupName = atom() +%% TestCase = atom() +%% Reason = term() +%% @end +%%-------------------------------------------------------------------- +all() -> + [{group,g1},tc1,tc2,{group,g2}]. + +tc1(_C) -> + ok. +tc2(_C) -> + ok. +tc3(_C) -> + ok. +tc4(_C) -> + ok. +tc5(_C) -> + ok. diff --git a/lib/common_test/test/ct_test_support.erl b/lib/common_test/test/ct_test_support.erl index 4132995bf6..67e430f821 100644 --- a/lib/common_test/test/ct_test_support.erl +++ b/lib/common_test/test/ct_test_support.erl @@ -38,7 +38,7 @@ -export([start_slave/3, slave_stop/1]). --export([ct_test_halt/1]). +-export([ct_test_halt/1, ct_rpc/2]). -include_lib("kernel/include/file.hrl"). @@ -65,7 +65,6 @@ init_per_suite(Config, Level) -> _ -> ok end, - start_slave(Config, Level). start_slave(Config, Level) -> @@ -103,6 +102,14 @@ start_slave(NodeName, Config, Level) -> test_server:format(Level, "Dirs added to code path (on ~w):~n", [CTNode]), [io:format("~s~n", [D]) || D <- PathDirs], + + case proplists:get_value(start_sasl, Config) of + true -> + rpc:call(CTNode, application, start, [sasl]), + test_server:format(Level, "SASL started on ~w~n", [CTNode]); + _ -> + ok + end, TraceFile = filename:join(DataDir, "ct.trace"), case file:read_file_info(TraceFile) of @@ -378,6 +385,16 @@ wait_for_ct_stop(Retries, CTNode) -> end. %%%----------------------------------------------------------------- +%%% ct_rpc/1 +ct_rpc({M,F,A}, Config) -> + CTNode = proplists:get_value(ct_node, Config), + Level = proplists:get_value(trace_level, Config), + test_server:format(Level, "~nCalling ~w:~w(~p) on ~p...", + [M,F,A, CTNode]), + rpc:call(CTNode, M, F, A). + + +%%%----------------------------------------------------------------- %%% EVENT HANDLING handle_event(EH, Event) -> diff --git a/lib/compiler/src/genop.tab b/lib/compiler/src/genop.tab index 75ac91907a..ebc9b1c85b 100644..100755 --- a/lib/compiler/src/genop.tab +++ b/lib/compiler/src/genop.tab @@ -23,45 +23,148 @@ BEAM_FORMAT_NUMBER=0 # arity or semantics, the format number above must be bumped. # +## @spec label Lbl +## @doc Specify a module local label. +## Label gives this code address a name (Lbl) and marks the start of +## a basic block. 1: label/1 + +## @spec func_info M F A +## @doc Define a function M:F/A 2: func_info/3 + 3: int_code_end/0 # # Function and BIF calls. # + +## @spec call Arity Label +## @doc Call the function at Label. +## Save the next instruction as the return address in the CP register. 4: call/2 + +## @spec call_last Arity Label Dellocate +## @doc Deallocate and do a tail recursive call to the function at Label. +## Do not update the CP register. +## Before the call deallocate Deallocate words of stack. 5: call_last/3 + +## @spec call_only Arity Label +## @doc Do a tail recursive call to the function at Label. +## Do not update the CP register. 6: call_only/2 +## @spec call_ext Arity Destination +## @doc Call the function of arity Arity pointed to by Destination. +## Save the next instruction as the return address in the CP register. 7: call_ext/2 + +## @spec call_ext_last Arity Destination Deallocate +## @doc Deallocate and do a tail call to function of arity Arity +## pointed to by Destination. +## Do not update the CP register. +## Deallocate Deallocate words from the stack before the call. 8: call_ext_last/3 +## @spec bif0 Bif Reg +## @doc Call the bif Bif and store the result in Reg. 9: bif0/2 + +## @spec bif1 Lbl Bif Arg Reg +## @doc Call the bif Bif with the argument Arg, and store the result in Reg. +## On failure jump to Lbl. 10: bif1/4 + +## @spec bif2 Lbl Bif Arg1 Arg2 Reg +## @doc Call the bif Bif with the arguments Arg1 and Arg2, +## and store the result in Reg. +## On failure jump to Lbl. 11: bif2/5 # # Allocating, deallocating and returning. # + +## @spec allocate StackNeed Live +## @doc Allocate space for StackNeed words on the stack. If a GC is needed +## during allocation there are Live number of live X registers. +## Also save the continuation pointer (CP) on the stack. 12: allocate/2 + +## @spec allocate_heap StackNeed HeapNeed Live +## @doc Allocate space for StackNeed words on the stack and ensure there is +## space for HeapNeed words on the heap. If a GC is needed +## save Live number of X registers. +## Also save the continuation pointer (CP) on the stack. 13: allocate_heap/3 + +## @spec allocate_zero StackNeed Live +## @doc Allocate space for StackNeed words on the stack. If a GC is needed +## during allocation there are Live number of live X registers. +## Clear the new stack words. (By writing NIL.) +## Also save the continuation pointer (CP) on the stack. 14: allocate_zero/2 + +## @spec allocate_heap_zero StackNeed HeapNeed Live +## @doc Allocate space for StackNeed words on the stack and HeapNeed words +## on the heap. If a GC is needed +## during allocation there are Live number of live X registers. +## Clear the new stack words. (By writing NIL.) +## Also save the continuation pointer (CP) on the stack. 15: allocate_heap_zero/3 + +## @spec test_heap HeapNeed Live +## @doc Ensure there is space for HeapNeed words on the heap. If a GC is needed +## save Live number of X registers. 16: test_heap/2 + +## @spec init N +## @doc Clear the Nth stack word. (By writing NIL.) 17: init/1 + +## @spec deallocate N +## @doc Restore the continuation pointer (CP) from the stack and deallocate +## N+1 words from the stack (the + 1 is for the CP). 18: deallocate/1 + +## @spec return +## @doc Return to the address in the continuation pointer (CP). 19: return/0 # # Sending & receiving. # +## @spec send +## @doc Send argument in x(0) as a message to the destination process in x(0). +## The message in x(1) ends up as the result of the send in x(0). 20: send/0 + +## @spec remove_message +## @doc Unlink the current message from the message queue and store a +## pointer to the message in x(0). Remove any timeout. 21: remove_message/0 + +## @spec timeout +## @doc Reset the save point of the mailbox and clear the timeout flag. 22: timeout/0 + +## @spec loop_rec Label Source +## @doc Loop over the message queue, if it is empty jump to Label. 23: loop_rec/2 + +## @spec loop_rec_end Label +## @doc Advance the save pointer to the next message and jump back to Label. 24: loop_rec_end/1 + +## @spec wait Label +## @doc Suspend the processes and set the entry point to the beginning of the +## receive loop at Label. 25: wait/1 + +## @spec wait_timeout Lable Time +## @doc Sets up a timeout of Time milllisecons and saves the address of the +## following instruction as the entry point if the timeout triggers. 26: wait_timeout/2 # @@ -83,36 +186,106 @@ BEAM_FORMAT_NUMBER=0 # # Comparision operators. # + +## @spec is_lt Lbl Arg1 Arg2 +## @doc Compare two terms and jump to Lbl if Arg1 is not less than Arg2. 39: is_lt/3 + +## @spec is_ge Lbl Arg1 Arg2 +## @doc Compare two terms and jump to Lbl if Arg1 is less than Arg2. 40: is_ge/3 + +## @spec is_eq Lbl Arg1 Arg2 +## @doc Compare two terms and jump to Lbl if Arg1 is not (numerically) equal to Arg2. 41: is_eq/3 + +## @spec is_ne Lbl Arg1 Arg2 +## @doc Compare two terms and jump to Lbl if Arg1 is (numerically) equal to Arg2. 42: is_ne/3 + +## @spec is_eq_exact Lbl Arg1 Arg2 +## @doc Compare two terms and jump to Lbl if Arg1 is not exactly equal to Arg2. 43: is_eq_exact/3 + +## @spec is_ne_exact Lbl Arg1 Arg2 +## @doc Compare two terms and jump to Lbl if Arg1 is exactly equal to Arg2. 44: is_ne_exact/3 # # Type tests. # + +## @spec is_integer Lbl Arg1 +## @doc Test the type of Arg1 and jump to Lbl if it is not an integer. 45: is_integer/2 + +## @spec is_float Lbl Arg1 +## @doc Test the type of Arg1 and jump to Lbl if it is not a float. 46: is_float/2 + +## @spec is_number Lbl Arg1 +## @doc Test the type of Arg1 and jump to Lbl if it is not a number. 47: is_number/2 + +## @spec is_atom Lbl Arg1 +## @doc Test the type of Arg1 and jump to Lbl if it is not an atom. 48: is_atom/2 + +## @spec is_pid Lbl Arg1 +## @doc Test the type of Arg1 and jump to Lbl if it is not a pid. 49: is_pid/2 + +## @spec is_reference Lbl Arg1 +## @doc Test the type of Arg1 and jump to Lbl if it is not a reference. 50: is_reference/2 + +## @spec is_port Lbl Arg1 +## @doc Test the type of Arg1 and jump to Lbl if it is not a port. 51: is_port/2 + +## @spec is_nil Lbl Arg1 +## @doc Test the type of Arg1 and jump to Lbl if it is not nil. 52: is_nil/2 + +## @spec is_binary Lbl Arg1 +## @doc Test the type of Arg1 and jump to Lbl if it is not a binary. 53: is_binary/2 + 54: -is_constant/2 + +## @spec is_list Lbl Arg1 +## @doc Test the type of Arg1 and jump to Lbl if it is not a cons or nil. 55: is_list/2 + +## @spec is_nonempty_list Lbl Arg1 +## @doc Test the type of Arg1 and jump to Lbl if it is not a cons. 56: is_nonempty_list/2 + +## @spec is_tuple Lbl Arg1 +## @doc Test the type of Arg1 and jump to Lbl if it is not a tuple. 57: is_tuple/2 + +## @spec test_arity Lbl Arg1 Arity +## @doc Test the arity of (the tuple in) Arg1 and jump +## to Lbl if it is not equal to Arity. 58: test_arity/3 # # Indexing & jumping. # + +## @spec select_val Arg FailLabel Destinations +## @doc Jump to the destination label corresponding to Arg +## in the Destinations list, if no arity matches, jump to FailLabel. 59: select_val/3 + +## @spec select_tuple_arity Tuple FailLabel Destinations +## @doc Check the arity of the tuple Tuple and jump to the corresponding +## destination label, if no arity matches, jump to FailLabel. 60: select_tuple_arity/3 + +## @spec jump Label +## @doc Jump to Label. 61: jump/1 # @@ -124,9 +297,26 @@ BEAM_FORMAT_NUMBER=0 # # Moving, extracting, modifying. # + +## @spec move Source Destination +## @doc Move the source Source (a literal or a register) to +## the destination register Destination. 64: move/2 + +## @spec get_list Source Head Tail +## @doc Get the head and tail (or car and cdr) parts of a list +## (a cons cell) from Source and put them into the registers +## Head and Tail. 65: get_list/3 + +## @spec get_tuple_element Source Element Destination +## @doc Get element number Element from the tuple in Source and put +## it in the destination register Destination. 66: get_tuple_element/3 + +## @spec set_tuple_element NewElement Tuple Position +## @doc Update the element at postition Position of the tuple Tuple +## with the new element NewElement. 67: set_tuple_element/3 # @@ -147,13 +337,26 @@ BEAM_FORMAT_NUMBER=0 # # 'fun' support. # +## @spec call_fun Arity +## @doc Call a fun of arity Arity. Assume arguments in +## registers x(0) to x(Arity-1) and that the fun is in x(Arity). +## Save the next instruction as the return address in the CP register. 75: call_fun/1 + 76: -make_fun/3 + +## @spec is_function Lbl Arg1 +## @doc Test the type of Arg1 and jump to Lbl if it is not a +## function (i.e. fun or closure). 77: is_function/2 # # Late additions to R5. # + +## @spec call_ext_only Arity Label +## Do a tail recursive call to the function at Label. +## Do not update the CP register. 78: call_ext_only/2 # @@ -212,9 +415,14 @@ BEAM_FORMAT_NUMBER=0 111: bs_add/5 112: apply/1 113: apply_last/2 +## @spec is_boolean Lbl Arg1 +## @doc Test the type of Arg1 and jump to Lbl if it is not a Boolean. 114: is_boolean/2 # New instructions in R10B-6. +## @spec is_function2 Lbl Arg1 Arity +## @doc Test the type of Arg1 and jump to Lbl if it is not a +## function of arity Arity. 115: is_function2/3 # New bit syntax matching in R11B. @@ -229,7 +437,20 @@ BEAM_FORMAT_NUMBER=0 123: bs_restore2/2 # New GC bifs introduced in R11B. + +## @spec gc_bif1 Lbl Live Bif Arg Reg +## @doc Call the bif Bif with the argument Arg, and store the result in Reg. +## On failure jump to Lbl. +## Do a garbage collection if necessary to allocate space on the heap +## for the result (saving Live number of X registers). 124: gc_bif1/5 + +## @spec gc_bif2 Lbl Live Bif Arg1 Arg2 Reg +## @doc Call the bif Bif with the arguments Arg1 and Arg2, +## and store the result in Reg. +## On failure jump to Lbl. +## Do a garbage collection if necessary to allocate space on the heap +## for the result (saving Live number of X registers). 125: gc_bif2/6 # Experimental new bit_level bifs introduced in R11B. @@ -241,6 +462,8 @@ BEAM_FORMAT_NUMBER=0 128: -put_literal/2 # R11B-5 +## @spec is_bitstr Lbl Arg1 +## @doc Test the type of Arg1 and jump to Lbl if it is not a bit string. 129: is_bitstr/2 # R12B @@ -250,7 +473,12 @@ BEAM_FORMAT_NUMBER=0 133: bs_init_writable/0 134: bs_append/8 135: bs_private_append/6 + +## @spec trim N Remaining +## @doc Reduce the stack usage by N words, +## keeping the CP on the top of the stack. 136: trim/2 + 137: bs_init_bits/6 # R12B-5 @@ -277,8 +505,24 @@ BEAM_FORMAT_NUMBER=0 # R14A +## @spec recv_mark Label +## @doc Save the end of the message queue and the address of +## the label Label so that a recv_set instruction can start +## scanning the inbox from this position. 150: recv_mark/1 + +## @spec recv_set Label +## @doc Check that the saved mark points to Label and set the +## save pointer in the message queue to the last position +## of the message queue saved by the recv_mark instruction. 151: recv_set/1 + +## @spec gc_bif3 Lbl Live Bif Arg1 Arg2 Arg3 Reg +## @doc Call the bif Bif with the arguments Arg1, Arg2 and Arg3, +## and store the result in Reg. +## On failure jump to Lbl. +## Do a garbage collection if necessary to allocate space on the heap +## for the result (saving Live number of X registers). 152: gc_bif3/7 # R15A diff --git a/lib/erl_interface/src/Makefile.in b/lib/erl_interface/src/Makefile.in index ebacc1cee0..e36b39c1fb 100644 --- a/lib/erl_interface/src/Makefile.in +++ b/lib/erl_interface/src/Makefile.in @@ -866,8 +866,12 @@ release: opt $(INSTALL_DIR) "$(RELSYSDIR)/src/misc" $(INSTALL_DIR) "$(RELSYSDIR)/src/prog" $(INSTALL_DIR) "$(RELSYSDIR)/src/registry" + $(INSTALL_DIR) "$(RELEASE_PATH)/usr/include" + $(INSTALL_DIR) "$(RELEASE_PATH)/usr/lib" $(INSTALL_DATA) $(HEADERS) "$(RELSYSDIR)/include" + $(INSTALL_DATA) $(HEADERS) "$(RELEASE_PATH)/usr/include" $(INSTALL_DATA) $(OBJ_TARGETS) "$(RELSYSDIR)/lib" + $(INSTALL_DATA) $(OBJ_TARGETS) "$(RELEASE_PATH)/usr/lib" ifneq ($(EXE_TARGETS),) $(INSTALL_PROGRAM) $(EXE_TARGETS) "$(RELSYSDIR)/bin" endif diff --git a/lib/erl_interface/test/ei_decode_encode_SUITE.erl b/lib/erl_interface/test/ei_decode_encode_SUITE.erl index 2271278291..c7830f58f2 100644 --- a/lib/erl_interface/test/ei_decode_encode_SUITE.erl +++ b/lib/erl_interface/test/ei_decode_encode_SUITE.erl @@ -68,6 +68,8 @@ test_ei_decode_encode(Config) when is_list(Config) -> Port = case os:type() of {win32,_} -> open_port({spawn,"sort"},[]); + {unix, darwin} -> + open_port({spawn,"/usr/bin/true"},[]); _ -> open_port({spawn,"/bin/true"},[]) end, diff --git a/lib/ic/c_src/Makefile.in b/lib/ic/c_src/Makefile.in index 856823b1b3..6e65f06114 100644 --- a/lib/ic/c_src/Makefile.in +++ b/lib/ic/c_src/Makefile.in @@ -149,9 +149,13 @@ release_spec: opt $(INSTALL_DIR) "$(RELSYSDIR)/c_src" $(INSTALL_DIR) "$(RELSYSDIR)/include" $(INSTALL_DIR) "$(RELSYSDIR)/priv/lib" + $(INSTALL_DIR) "$(RELEASE_PATH)/usr/include" + $(INSTALL_DIR) "$(RELEASE_PATH)/usr/lib" $(INSTALL_DATA) ic.c ic_tmo.c "$(RELSYSDIR)/c_src" $(INSTALL_DATA) $(IDL_FILES) $(H_FILES) "$(RELSYSDIR)/include" $(INSTALL_DATA) $(LIBRARY) "$(RELSYSDIR)/priv/lib" + $(INSTALL_DATA) $(IDL_FILES) $(H_FILES) "$(RELEASE_PATH)/usr/include" + $(INSTALL_DATA) $(LIBRARY) "$(RELEASE_PATH)/usr/lib" release_docs_spec: diff --git a/lib/inets/test/Makefile b/lib/inets/test/Makefile index dfa86906fd..2f2f6ec16e 100644 --- a/lib/inets/test/Makefile +++ b/lib/inets/test/Makefile @@ -215,7 +215,7 @@ INETS_FILES = inets.config $(INETS_SPECS) # inets_tftp_suite INETS_DATADIRS = inets_SUITE_data inets_sup_SUITE_data -HTTPD_DATADIRS = httpd_test_data httpd_SUITE_data +HTTPD_DATADIRS = httpd_test_data httpd_SUITE_data httpd_basic_SUITE_data HTTPC_DATADIRS = httpc_SUITE_data httpc_proxy_SUITE_data FTP_DATADIRS = ftp_SUITE_data diff --git a/lib/inets/test/httpc_SUITE_data/ssl_client_cert.pem b/lib/inets/test/httpc_SUITE_data/ssl_client_cert.pem index f274d2021d..427447958d 100644 --- a/lib/inets/test/httpc_SUITE_data/ssl_client_cert.pem +++ b/lib/inets/test/httpc_SUITE_data/ssl_client_cert.pem @@ -1,22 +1,31 @@ -----BEGIN RSA PRIVATE KEY----- -MIIBOwIBAAJBANz7eFvORmJDi1XJMM2U3uHC5wmp/DXTLMw08XaEvtZ73wgVg84E -V0oyX3Kh1thRE3Hch9AyrHjgpizCj9/Ra38CAwEAAQJACzpz2SZYCTIpaEh6xFdm -I86FcsZCXHHIeu/NvRntoHQ+nfM7Np379+z6XNJWIcWh/QgG/jNJalR1BO+eyc6/ -YQIhAP3m8M0LDxJwSgHFtGAGatQqaqw9l48Kq5xdMFqvdpiHAiEA3s7lld6yCJYu -6q7fZjTH+eKUwgg0vpgJutP7Fsok60kCIHHesQBEhW3vjkFdOZgXSLH+k/jLZr1w -O6bU5GrHZpjhAiEAyTvGYcjDtTunXjDY9l+fadK6FlEBCk8ZIpNIiTnDhHkCIQDr -QxxLLuNHRj8iWNbuVVZ99SJy8zC33pMgPFaFKaZesQ== +MIICXQIBAAKBgQCTFBPkOO98fDY3j6MIxIGKp+rampfIay50Lx4+EnCnRSSVwC+n +0VVmP7V5SGFJpuXJzN0hvqPUWOOjiMTNlNRaGy0pqu2oMXWAPLOxHWL1wT53h2Zr +3FUNU/N0Rvnkttse1KZJ9uYCLKUiuXXsv2rR62nH3OhRIiBHSAcSv0NRWwIDAQAB +AoGACdIVYe/LTeydUihtInC8lZ2QuPgJmoBNocRjqJFipEihoL4scHAx25n1bBvB +I0HZphffzBkGp28oBAtl2LRPWXqu527unc/RWRfLMqSK1xNSq1DxD1a30zkrZPna +QiV65vEJuNSJTtlDy/Zqc/BVZXCpxWlzYQedZgkmf0Qse8ECQQCmaz02Yur8zC9f +eSQKU5OSzGw3bSIumEzziCfHdTheK6MEoccf5TCAyLXhZwA7QlKja4tFXfeyVxws +/LlnUJN9AkEA4j+xnOeYUyGKXL5i+BAbnqpI4MzPiq+IoCYkaRlD/wAws24r5HNI +ZQmEHWqD/NNzOf/A2XuyLtMiTGJPW/DftwJBAKKpJP6Ytuh6xz8BUCnLwO12Y7vV +LtjuQiCzD3aUa5EYA9HOMqxJPxxRkf0LyR0i2VUkE8+sZiPpov+R0cJa7p0CQQCj +40GUiArGRSiF7/+e84QeVfl+pb29F1QftiFv5DZmFEwy3Z572KpbTh5edJbxYHY6 +UDHxGHJFCvnwXNJhpkVXAkBJqfEfiMJ3Q/E5Gpf3sQizacouW92iiN8ojlF1oB80 +t34RysJH7SgI3gdMhTribCo2UUaV0StjR6yodPN+TB2J -----END RSA PRIVATE KEY----- -----BEGIN CERTIFICATE----- -MIIB7jCCAZgCAQAwDQYJKoZIhvcNAQEEBQAwgYExCzAJBgNVBAYTAlNFMRIwEAYD -VQQHEwlTdG9ja2hvbG0xETAPBgNVBAoTCEVyaWNzc29uMQwwCgYDVQQLEwNFVFgx -FjAUBgNVBAMTDUhlbGVuIEFpcml5YW4xJTAjBgkqhkiG9w0BCQEWFmhlbGVuQGVy -aXguZXJpY3Nzb24uc2UwHhcNOTcwNzI4MDcxNDI1WhcNOTgxMjEwMDcxNDI1WjCB -gTELMAkGA1UEBhMCU0UxEjAQBgNVBAcTCVN0b2NraG9sbTERMA8GA1UEChMIRXJp -Y3Nzb24xDDAKBgNVBAsTA0VUWDEWMBQGA1UEAxMNSGVsZW4gQWlyaXlhbjElMCMG -CSqGSIb3DQEJARYWaGVsZW5AZXJpeC5lcmljc3Nvbi5zZTBcMA0GCSqGSIb3DQEB -AQUAA0sAMEgCQQDc+3hbzkZiQ4tVyTDNlN7hwucJqfw10yzMNPF2hL7We98IFYPO -BFdKMl9yodbYURNx3IfQMqx44KYswo/f0Wt/AgMBAAEwDQYJKoZIhvcNAQEEBQAD -QQC2++hLIaQJ4ChCjFE9UCfXO9cZ3Vq/FT9VjE+G4MRBDo4LQ5mBKNXcPF6EFZmi -7XrlvopXkVPlRguTi2SLRPkY +MIIChzCCAfCgAwIBAgIGAIsapa8BMA0GCSqGSIb3DQEBBQUAMHoxDjAMBgNVBAMT +BW90cENBMSAwHgYJKoZIhvcNAQkBFhF0ZXN0ZXJAZXJsYW5nLm9yZzESMBAGA1UE +BxMJU3RvY2tob2xtMQswCQYDVQQGEwJTRTEPMA0GA1UEChMGZXJsYW5nMRQwEgYD +VQQLEwt0ZXN0aW5nIGRlcDAiGA8yMDEwMDkwMTAwMDAwMFoYDzIwMjUwODI4MDAw +MDAwWjB7MQ8wDQYDVQQDEwZjbGllbnQxIDAeBgkqhkiG9w0BCQEWEXRlc3RlckBl +cmxhbmcub3JnMRIwEAYDVQQHEwlTdG9ja2hvbG0xCzAJBgNVBAYTAlNFMQ8wDQYD +VQQKEwZlcmxhbmcxFDASBgNVBAsTC3Rlc3RpbmcgZGVwMIGfMA0GCSqGSIb3DQEB +AQUAA4GNADCBiQKBgQCTFBPkOO98fDY3j6MIxIGKp+rampfIay50Lx4+EnCnRSSV +wC+n0VVmP7V5SGFJpuXJzN0hvqPUWOOjiMTNlNRaGy0pqu2oMXWAPLOxHWL1wT53 +h2Zr3FUNU/N0Rvnkttse1KZJ9uYCLKUiuXXsv2rR62nH3OhRIiBHSAcSv0NRWwID +AQABoxMwETAPBgNVHRMBAf8EBTADAQH/MA0GCSqGSIb3DQEBBQUAA4GBAG8t6f1A +PF7xayGxtUpG2r6W5ETylC3ZIKPS2kfJk9aYi7AZNTp7/xTU6SgqvFBN8aBPzxCD +4jHrSNC8DSb4X1x9uimarb6qdZDHEdij+DRAd2eygJHZxEf7+8B4Fx34thQeU9hZ +S1Izke5AlsyFMkvB7h0anE4k9BfuU70vl6v5 -----END CERTIFICATE----- diff --git a/lib/inets/test/httpc_SUITE_data/ssl_server_cert.pem b/lib/inets/test/httpc_SUITE_data/ssl_server_cert.pem index f01b6c992b..4aac86db49 100644 --- a/lib/inets/test/httpc_SUITE_data/ssl_server_cert.pem +++ b/lib/inets/test/httpc_SUITE_data/ssl_server_cert.pem @@ -1,22 +1,31 @@ -----BEGIN RSA PRIVATE KEY----- -MIIBOQIBAAJBAMe2WhP6s+JeKOwWPEjI9susfN4Vjn2dd1X4QUlOETcWVLoF916m -M4JU+ms7+ciMR8GRNCsIeqZGY8/GSqm74ccCAwEAAQJAF08YKlbLYfM9cXiS5qfV -7iWemUkIzW5wfC8yZ3zeE4Cp6R9ViUfs/dadQ/23Cw0Bpo2t8UdTUdCa4KpmqOem -cQIhAOnxTWZ5eo6h6PXDp7L5FZUACg8+wT3qf5f2is2mbSZPAiEA2orUY8JZDTSk -Rm7q9WxLiLNtORsXdTCmnCWhqBOYpwkCIErdowRxScxNekz0IT3AQqzdR1rbnWHg -IpcSGhd39CQ3AiA1XvQxjLP8wp9fyBS/bPwhXVhOOuyGpSP7PEF3b5m3KQIgGQWc -/a5wuWx3pc3mLx0ILwNoJr2ubFEuW1PJPsPJPv0= +MIICXQIBAAKBgQCf4Htxr99lLs5W8QQw7jdakqyAkIjOW4aqH8sr4va4SvZ9Adq6 +7k8jMHefCVZo+F8x4cwsBgB4aWzFIGBnvFTi6YsH27XW7f9O9IPCej8fdhRZ4UAt +NHa253buOWpDGla2JmIdkmfFvXFJycMIKbG5tYilVXoWKBMKmCwWaXz0nQIDAQAB +AoGAQIlma0r6W6bcRj4+Wd4fXCFvHuq5Psu1fYEeC5Yvz8761xVjjSfbrDHJZ9pm +FjOEgedK+s5lbDXqYVyjbdyZSugStBRocSmbG8SQHcAsxR2ZIkNzX2hYzB+lslWo +T3YJojDyB134O7XJznCu+ZFXP86jyJ1JT6k6a+OIHcwnJ+ECQQDYn57dY4Px3mEd +VBLStN3YkRF5oFyT+xk7IaKeLLB6n4gCnoVbBoHut7PFbPYPzoNzEwPk3MQKDIHb +Kig3S5CpAkEAvPA1VmoJWAlN6kUi+F2L8HXEArzE8x7vwdsslrwMKUe4dFS+ZC/7 +5iDOaxcZ7TYkCgwzBt341++DCgP6j3fY1QJBALB6AcOcwi52m6l4B8mu3ZkEPjdX +BHTuONTqhv/TqoaLlxODL2NDvvDKqeMp7KBd/srt79swW2lQXS4+fvrlTdkCQQCm +zxj4O1QWkthkfje6ubSkTwUIOatUzrp1F9GNH2dJRtX2dx9FCwxGCC7WY6XzRXqa +GF0wsedSllbGD+82nWQlAkAicMGqCqRq4hKR/cVmFatOqKVWCVkx6OFF2FhuiI5Z +h5eIOPGCt8dVRs1P9DNSld/D98Sfm65m85z8BtXovvYV -----END RSA PRIVATE KEY----- -----BEGIN CERTIFICATE----- -MIIB7jCCAZgCAQAwDQYJKoZIhvcNAQEEBQAwgYExCzAJBgNVBAYTAlNFMRIwEAYD -VQQHEwlTdG9ja2hvbG0xETAPBgNVBAoTCEVyaWNzc29uMQwwCgYDVQQLEwNFVFgx -FjAUBgNVBAMTDUhlbGVuIEFpcml5YW4xJTAjBgkqhkiG9w0BCQEWFmhlbGVuQGVy -aXguZXJpY3Nzb24uc2UwHhcNOTcwNzI4MDcyMTAwWhcNOTgxMjEwMDcyMTAwWjCB -gTELMAkGA1UEBhMCU0UxEjAQBgNVBAcTCVN0b2NraG9sbTERMA8GA1UEChMIRXJp -Y3Nzb24xDDAKBgNVBAsTA0VUWDEWMBQGA1UEAxMNSGVsZW4gQWlyaXlhbjElMCMG -CSqGSIb3DQEJARYWaGVsZW5AZXJpeC5lcmljc3Nvbi5zZTBcMA0GCSqGSIb3DQEB -AQUAA0sAMEgCQQDHtloT+rPiXijsFjxIyPbLrHzeFY59nXdV+EFJThE3FlS6Bfde -pjOCVPprO/nIjEfBkTQrCHqmRmPPxkqpu+HHAgMBAAEwDQYJKoZIhvcNAQEEBQAD -QQCnU1TkxmfbLdUwjdECb5x9QHCevAR7AmTms4Csn2oOEyPX+bgF2d94xhrV1sxO -Rs0yigk1PtN17Ci0Dey0LYkR +MIIChzCCAfCgAwIBAgIGANUxXM9BMA0GCSqGSIb3DQEBBQUAMHoxDjAMBgNVBAMT +BW90cENBMSAwHgYJKoZIhvcNAQkBFhF0ZXN0ZXJAZXJsYW5nLm9yZzESMBAGA1UE +BxMJU3RvY2tob2xtMQswCQYDVQQGEwJTRTEPMA0GA1UEChMGZXJsYW5nMRQwEgYD +VQQLEwt0ZXN0aW5nIGRlcDAiGA8yMDEwMDkwMTAwMDAwMFoYDzIwMjUwODI4MDAw +MDAwWjB7MQ8wDQYDVQQDEwZzZXJ2ZXIxIDAeBgkqhkiG9w0BCQEWEXRlc3RlckBl +cmxhbmcub3JnMRIwEAYDVQQHEwlTdG9ja2hvbG0xCzAJBgNVBAYTAlNFMQ8wDQYD +VQQKEwZlcmxhbmcxFDASBgNVBAsTC3Rlc3RpbmcgZGVwMIGfMA0GCSqGSIb3DQEB +AQUAA4GNADCBiQKBgQCf4Htxr99lLs5W8QQw7jdakqyAkIjOW4aqH8sr4va4SvZ9 +Adq67k8jMHefCVZo+F8x4cwsBgB4aWzFIGBnvFTi6YsH27XW7f9O9IPCej8fdhRZ +4UAtNHa253buOWpDGla2JmIdkmfFvXFJycMIKbG5tYilVXoWKBMKmCwWaXz0nQID +AQABoxMwETAPBgNVHRMBAf8EBTADAQH/MA0GCSqGSIb3DQEBBQUAA4GBAGF5Pfwk +QDdwJup/mVITPxbBls4Yl7anDooUQsq8066lA1g54H/PRfXscGkyCFGh1ifXvf1L +psMRoBAdDHL/wSJplk3rRavkC94eBgnTFZmfKL6844g1j53yameiYL8IEVExYMBg +/XGyc0qwq57WT8B/K4aElrvlBlQ0wF3wN54M -----END CERTIFICATE----- diff --git a/lib/inets/test/httpd_SUITE.erl b/lib/inets/test/httpd_SUITE.erl index 1efa78a63e..5dca76b76b 100644 --- a/lib/inets/test/httpd_SUITE.erl +++ b/lib/inets/test/httpd_SUITE.erl @@ -1919,7 +1919,7 @@ ticket_5865(Config) -> " HTTP/1.1\r\nHost:" ++Host++"\r\n\r\n", [{statuscode, 200}, - {no_last_modified, + {no_header, "last-modified"}]), ok; {error, Reason} -> diff --git a/lib/inets/test/httpd_SUITE_data/server_root/ssl/ssl_client.pem b/lib/inets/test/httpd_SUITE_data/server_root/ssl/ssl_client.pem index 8221139eb4..427447958d 100644 --- a/lib/inets/test/httpd_SUITE_data/server_root/ssl/ssl_client.pem +++ b/lib/inets/test/httpd_SUITE_data/server_root/ssl/ssl_client.pem @@ -1,22 +1,31 @@ -----BEGIN RSA PRIVATE KEY----- -MIIBPAIBAAJBAL6Ym/bgUvhhnPkw08sggGg8Tnp759ThGMEjkmDzhuJ3w3PfnF65 -mgHcgunku4G6LxAQfEUougJWf9Phmjj3oRUCAwEAAQJBAKMjvVvzZxFzfAlP4flc -OI0AEayFokp04dtvtzuFN09f+aBo2dP18xHmKLCZvxrBOaRAROoQYscALiIVpN07 -GAECIQDfi+sSfAFaDlT3vzpL3xE5UEH6IzY8jWpaZfM1QaToJQIhANpEF50H4wGO -8Sbh7dUutNd+s+NYUjsMySW2DjLKMsoxAiEAzzb2ftrdsempD0F+O0gZwiPIFKLB -Kp33YLYyHEKuJtUCIDGi+pvDh2R7VWw6RRQOIyI+tjolg83aAoSI+oGiahqBAiEA -xzmNNajwoaokvWvlaz0na8rhxu45grOvDrflBT9XvSQ= +MIICXQIBAAKBgQCTFBPkOO98fDY3j6MIxIGKp+rampfIay50Lx4+EnCnRSSVwC+n +0VVmP7V5SGFJpuXJzN0hvqPUWOOjiMTNlNRaGy0pqu2oMXWAPLOxHWL1wT53h2Zr +3FUNU/N0Rvnkttse1KZJ9uYCLKUiuXXsv2rR62nH3OhRIiBHSAcSv0NRWwIDAQAB +AoGACdIVYe/LTeydUihtInC8lZ2QuPgJmoBNocRjqJFipEihoL4scHAx25n1bBvB +I0HZphffzBkGp28oBAtl2LRPWXqu527unc/RWRfLMqSK1xNSq1DxD1a30zkrZPna +QiV65vEJuNSJTtlDy/Zqc/BVZXCpxWlzYQedZgkmf0Qse8ECQQCmaz02Yur8zC9f +eSQKU5OSzGw3bSIumEzziCfHdTheK6MEoccf5TCAyLXhZwA7QlKja4tFXfeyVxws +/LlnUJN9AkEA4j+xnOeYUyGKXL5i+BAbnqpI4MzPiq+IoCYkaRlD/wAws24r5HNI +ZQmEHWqD/NNzOf/A2XuyLtMiTGJPW/DftwJBAKKpJP6Ytuh6xz8BUCnLwO12Y7vV +LtjuQiCzD3aUa5EYA9HOMqxJPxxRkf0LyR0i2VUkE8+sZiPpov+R0cJa7p0CQQCj +40GUiArGRSiF7/+e84QeVfl+pb29F1QftiFv5DZmFEwy3Z572KpbTh5edJbxYHY6 +UDHxGHJFCvnwXNJhpkVXAkBJqfEfiMJ3Q/E5Gpf3sQizacouW92iiN8ojlF1oB80 +t34RysJH7SgI3gdMhTribCo2UUaV0StjR6yodPN+TB2J -----END RSA PRIVATE KEY----- -----BEGIN CERTIFICATE----- -MIICDDCCAbYCAQAwDQYJKoZIhvcNAQEEBQAwgZAxCzAJBgNVBAYTAlNFMRIwEAYD -VQQIEwlTdG9ja2hvbG0xDzANBgNVBAcTBkFsdnNqbzEMMAoGA1UEChMDRVRYMQ4w -DAYDVQQLEwVETi9TUDEXMBUGA1UEAxMOSm9ha2ltIEdyZWJlbm8xJTAjBgkqhkiG -9w0BCQEWFmpvY2tlQGVyaXguZXJpY3Nzb24uc2UwHhcNOTcwNzE1MTUzNDM2WhcN -MDMwMjIyMTUzNDM2WjCBkDELMAkGA1UEBhMCU0UxEjAQBgNVBAgTCVN0b2NraG9s -bTEPMA0GA1UEBxMGQWx2c2pvMQwwCgYDVQQKEwNFVFgxDjAMBgNVBAsTBUROL1NQ -MRcwFQYDVQQDEw5Kb2FraW0gR3JlYmVubzElMCMGCSqGSIb3DQEJARYWam9ja2VA -ZXJpeC5lcmljc3Nvbi5zZTBcMA0GCSqGSIb3DQEBAQUAA0sAMEgCQQC+mJv24FL4 -YZz5MNPLIIBoPE56e+fU4RjBI5Jg84bid8Nz35xeuZoB3ILp5LuBui8QEHxFKLoC -Vn/T4Zo496EVAgMBAAEwDQYJKoZIhvcNAQEEBQADQQBYxQVfTydyZCE0UXvZd7Ei -josNsAaWJk9fFIJaG9uyXCEfg2dVgoT2eBk3D9DI+7OB+78isM5CVlFbL7hilvP8 +MIIChzCCAfCgAwIBAgIGAIsapa8BMA0GCSqGSIb3DQEBBQUAMHoxDjAMBgNVBAMT +BW90cENBMSAwHgYJKoZIhvcNAQkBFhF0ZXN0ZXJAZXJsYW5nLm9yZzESMBAGA1UE +BxMJU3RvY2tob2xtMQswCQYDVQQGEwJTRTEPMA0GA1UEChMGZXJsYW5nMRQwEgYD +VQQLEwt0ZXN0aW5nIGRlcDAiGA8yMDEwMDkwMTAwMDAwMFoYDzIwMjUwODI4MDAw +MDAwWjB7MQ8wDQYDVQQDEwZjbGllbnQxIDAeBgkqhkiG9w0BCQEWEXRlc3RlckBl +cmxhbmcub3JnMRIwEAYDVQQHEwlTdG9ja2hvbG0xCzAJBgNVBAYTAlNFMQ8wDQYD +VQQKEwZlcmxhbmcxFDASBgNVBAsTC3Rlc3RpbmcgZGVwMIGfMA0GCSqGSIb3DQEB +AQUAA4GNADCBiQKBgQCTFBPkOO98fDY3j6MIxIGKp+rampfIay50Lx4+EnCnRSSV +wC+n0VVmP7V5SGFJpuXJzN0hvqPUWOOjiMTNlNRaGy0pqu2oMXWAPLOxHWL1wT53 +h2Zr3FUNU/N0Rvnkttse1KZJ9uYCLKUiuXXsv2rR62nH3OhRIiBHSAcSv0NRWwID +AQABoxMwETAPBgNVHRMBAf8EBTADAQH/MA0GCSqGSIb3DQEBBQUAA4GBAG8t6f1A +PF7xayGxtUpG2r6W5ETylC3ZIKPS2kfJk9aYi7AZNTp7/xTU6SgqvFBN8aBPzxCD +4jHrSNC8DSb4X1x9uimarb6qdZDHEdij+DRAd2eygJHZxEf7+8B4Fx34thQeU9hZ +S1Izke5AlsyFMkvB7h0anE4k9BfuU70vl6v5 -----END CERTIFICATE----- diff --git a/lib/inets/test/httpd_SUITE_data/server_root/ssl/ssl_server.pem b/lib/inets/test/httpd_SUITE_data/server_root/ssl/ssl_server.pem index fe739c15f7..4aac86db49 100644 --- a/lib/inets/test/httpd_SUITE_data/server_root/ssl/ssl_server.pem +++ b/lib/inets/test/httpd_SUITE_data/server_root/ssl/ssl_server.pem @@ -1,22 +1,31 @@ -----BEGIN RSA PRIVATE KEY----- -MIIBOwIBAAJBAL9Bozj3BIjL5Cy8b3rjMT2kPZRychX4wz9bHoIIiKnKo1xXHYjw -g3N9zWM1f1ZzMADwVry1uAInA8q09+7hL20CAwEAAQJACwu2ao7RozjrV64WXimK -6X131P/7GMvCMwGHNIlbozqoOqmZcYrbKaF61l+XuwA2QvTo3ywW1Ivxcyr6TeAr -PQIhAOX+WXT6yiqqwjt08kjBCJyMgfZtdAO6pc/6pKjNWiZfAiEA1OH1iPW/OQe5 -tlQXpiRVdLyneNsPygPRJc4Bdwu3hbMCIQDbI5pA56QxOzqOREOGJsb5wrciAfAE -jZbnr72sSN2YqQIgAWFpvzagw9Tp/mWzNY+cwkIK7/yzsIKv04fveH8p9IMCIQCr -td4IiukeUwXmPSvYM4uCE/+J89wEL9qU8Mlc3gDLXA== +MIICXQIBAAKBgQCf4Htxr99lLs5W8QQw7jdakqyAkIjOW4aqH8sr4va4SvZ9Adq6 +7k8jMHefCVZo+F8x4cwsBgB4aWzFIGBnvFTi6YsH27XW7f9O9IPCej8fdhRZ4UAt +NHa253buOWpDGla2JmIdkmfFvXFJycMIKbG5tYilVXoWKBMKmCwWaXz0nQIDAQAB +AoGAQIlma0r6W6bcRj4+Wd4fXCFvHuq5Psu1fYEeC5Yvz8761xVjjSfbrDHJZ9pm +FjOEgedK+s5lbDXqYVyjbdyZSugStBRocSmbG8SQHcAsxR2ZIkNzX2hYzB+lslWo +T3YJojDyB134O7XJznCu+ZFXP86jyJ1JT6k6a+OIHcwnJ+ECQQDYn57dY4Px3mEd +VBLStN3YkRF5oFyT+xk7IaKeLLB6n4gCnoVbBoHut7PFbPYPzoNzEwPk3MQKDIHb +Kig3S5CpAkEAvPA1VmoJWAlN6kUi+F2L8HXEArzE8x7vwdsslrwMKUe4dFS+ZC/7 +5iDOaxcZ7TYkCgwzBt341++DCgP6j3fY1QJBALB6AcOcwi52m6l4B8mu3ZkEPjdX +BHTuONTqhv/TqoaLlxODL2NDvvDKqeMp7KBd/srt79swW2lQXS4+fvrlTdkCQQCm +zxj4O1QWkthkfje6ubSkTwUIOatUzrp1F9GNH2dJRtX2dx9FCwxGCC7WY6XzRXqa +GF0wsedSllbGD+82nWQlAkAicMGqCqRq4hKR/cVmFatOqKVWCVkx6OFF2FhuiI5Z +h5eIOPGCt8dVRs1P9DNSld/D98Sfm65m85z8BtXovvYV -----END RSA PRIVATE KEY----- -----BEGIN CERTIFICATE----- -MIICDDCCAbYCAQAwDQYJKoZIhvcNAQEEBQAwgZAxCzAJBgNVBAYTAlNFMRIwEAYD -VQQIEwlTdG9ja2hvbG0xDzANBgNVBAcTBkFsdnNqbzEMMAoGA1UEChMDRVRYMQ4w -DAYDVQQLEwVETi9TUDEXMBUGA1UEAxMOSm9ha2ltIEdyZWJlbm8xJTAjBgkqhkiG -9w0BCQEWFmpvY2tlQGVyaXguZXJpY3Nzb24uc2UwHhcNOTcwNzE1MTUzMzQxWhcN -MDMwMjIyMTUzMzQxWjCBkDELMAkGA1UEBhMCU0UxEjAQBgNVBAgTCVN0b2NraG9s -bTEPMA0GA1UEBxMGQWx2c2pvMQwwCgYDVQQKEwNFVFgxDjAMBgNVBAsTBUROL1NQ -MRcwFQYDVQQDEw5Kb2FraW0gR3JlYmVubzElMCMGCSqGSIb3DQEJARYWam9ja2VA -ZXJpeC5lcmljc3Nvbi5zZTBcMA0GCSqGSIb3DQEBAQUAA0sAMEgCQQC/QaM49wSI -y+QsvG964zE9pD2UcnIV+MM/Wx6CCIipyqNcVx2I8INzfc1jNX9WczAA8Fa8tbgC -JwPKtPfu4S9tAgMBAAEwDQYJKoZIhvcNAQEEBQADQQAmXDY1CyJjzvQZX442kkHG -ic9QFY1UuVfzokzNMwlHYl1Qx9zaodx0cJCrcH5GF9O9LJbhhV77LzoxT1Q5wZp5 +MIIChzCCAfCgAwIBAgIGANUxXM9BMA0GCSqGSIb3DQEBBQUAMHoxDjAMBgNVBAMT +BW90cENBMSAwHgYJKoZIhvcNAQkBFhF0ZXN0ZXJAZXJsYW5nLm9yZzESMBAGA1UE +BxMJU3RvY2tob2xtMQswCQYDVQQGEwJTRTEPMA0GA1UEChMGZXJsYW5nMRQwEgYD +VQQLEwt0ZXN0aW5nIGRlcDAiGA8yMDEwMDkwMTAwMDAwMFoYDzIwMjUwODI4MDAw +MDAwWjB7MQ8wDQYDVQQDEwZzZXJ2ZXIxIDAeBgkqhkiG9w0BCQEWEXRlc3RlckBl +cmxhbmcub3JnMRIwEAYDVQQHEwlTdG9ja2hvbG0xCzAJBgNVBAYTAlNFMQ8wDQYD +VQQKEwZlcmxhbmcxFDASBgNVBAsTC3Rlc3RpbmcgZGVwMIGfMA0GCSqGSIb3DQEB +AQUAA4GNADCBiQKBgQCf4Htxr99lLs5W8QQw7jdakqyAkIjOW4aqH8sr4va4SvZ9 +Adq67k8jMHefCVZo+F8x4cwsBgB4aWzFIGBnvFTi6YsH27XW7f9O9IPCej8fdhRZ +4UAtNHa253buOWpDGla2JmIdkmfFvXFJycMIKbG5tYilVXoWKBMKmCwWaXz0nQID +AQABoxMwETAPBgNVHRMBAf8EBTADAQH/MA0GCSqGSIb3DQEBBQUAA4GBAGF5Pfwk +QDdwJup/mVITPxbBls4Yl7anDooUQsq8066lA1g54H/PRfXscGkyCFGh1ifXvf1L +psMRoBAdDHL/wSJplk3rRavkC94eBgnTFZmfKL6844g1j53yameiYL8IEVExYMBg +/XGyc0qwq57WT8B/K4aElrvlBlQ0wF3wN54M -----END CERTIFICATE----- diff --git a/lib/inets/test/httpd_basic_SUITE.erl b/lib/inets/test/httpd_basic_SUITE.erl index fef0a1f0f4..b1fe373cff 100644 --- a/lib/inets/test/httpd_basic_SUITE.erl +++ b/lib/inets/test/httpd_basic_SUITE.erl @@ -19,6 +19,7 @@ %% -module(httpd_basic_SUITE). +-include_lib("kernel/include/file.hrl"). -include_lib("common_test/include/ct.hrl"). -include("inets_test_lib.hrl"). @@ -35,6 +36,7 @@ all() -> uri_too_long_414, header_too_long_413, erl_script_nocache_opt, + script_nocache, escaped_url_in_error_body, slowdose ]. @@ -63,6 +65,7 @@ init_per_suite(Config) -> "~n Config: ~p", [Config]), ok = inets:start(), PrivDir = ?config(priv_dir, Config), + DataDir = ?config(data_dir, Config), Dummy = "<HTML> @@ -75,6 +78,18 @@ DUMMY </HTML>", DummyFile = filename:join([PrivDir,"dummy.html"]), + CgiDir = filename:join(PrivDir, "cgi-bin"), + ok = file:make_dir(CgiDir), + Cgi = case test_server:os_type() of + {win32, _} -> + "printenv.bat"; + _ -> + "printenv.sh" + end, + inets_test_lib:copy_file(Cgi, DataDir, CgiDir), + AbsCgi = filename:join([CgiDir, Cgi]), + {ok, FileInfo} = file:read_file_info(AbsCgi), + ok = file:write_file_info(AbsCgi, FileInfo#file_info{mode = 8#00755}), {ok, Fd} = file:open(DummyFile, [write]), ok = file:write(Fd, Dummy), ok = file:close(Fd), @@ -85,7 +100,7 @@ DUMMY {document_root, PrivDir}, {bind_address, "localhost"}], - [{httpd_conf, HttpdConf} | Config]. + [{httpd_conf, HttpdConf}, {cgi_dir, CgiDir}, {cgi_script, Cgi} | Config]. %%-------------------------------------------------------------------- %% Function: end_per_suite(Config) -> _ @@ -205,6 +220,52 @@ erl_script_nocache_opt(Config) when is_list(Config) -> %%------------------------------------------------------------------------- %%------------------------------------------------------------------------- +script_nocache(doc) -> + ["Test nocache option for mod_cgi and mod_esi"]; +script_nocache(suite) -> + []; +script_nocache(Config) when is_list(Config) -> + Normal = {no_header, "cache-control"}, + NoCache = {header, "cache-control", "no-cache"}, + verify_script_nocache(Config, false, false, Normal, Normal), + verify_script_nocache(Config, true, false, NoCache, Normal), + verify_script_nocache(Config, false, true, Normal, NoCache), + verify_script_nocache(Config, true, true, NoCache, NoCache), + ok. + +verify_script_nocache(Config, CgiNoCache, EsiNoCache, CgiOption, EsiOption) -> + HttpdConf = ?config(httpd_conf, Config), + CgiScript = ?config(cgi_script, Config), + CgiDir = ?config(cgi_dir, Config), + {ok, Pid} = inets:start(httpd, [{port, 0}, + {script_alias, + {"/cgi-bin/", CgiDir ++ "/"}}, + {script_nocache, CgiNoCache}, + {erl_script_alias, + {"/cgi-bin/erl", [httpd_example,io]}}, + {erl_script_nocache, EsiNoCache} + | HttpdConf]), + Info = httpd:info(Pid), + Port = proplists:get_value(port, Info), + Address = proplists:get_value(bind_address, Info), + ok = httpd_test_lib:verify_request(ip_comm, Address, Port, node(), + "GET /cgi-bin/" ++ CgiScript ++ + " HTTP/1.0\r\n\r\n", + [{statuscode, 200}, + CgiOption, + {version, "HTTP/1.0"}]), + ok = httpd_test_lib:verify_request(ip_comm, Address, Port, node(), + "GET /cgi-bin/erl/httpd_example:get " + "HTTP/1.0\r\n\r\n", + [{statuscode, 200}, + EsiOption, + {version, "HTTP/1.0"}]), + inets:stop(httpd, Pid). + + +%%------------------------------------------------------------------------- +%%------------------------------------------------------------------------- + escaped_url_in_error_body(doc) -> ["Test Url-encoding see OTP-8940"]; escaped_url_in_error_body(suite) -> diff --git a/lib/inets/test/httpd_basic_SUITE_data/printenv.bat b/lib/inets/test/httpd_basic_SUITE_data/printenv.bat new file mode 120000 index 0000000000..1bc8e52059 --- /dev/null +++ b/lib/inets/test/httpd_basic_SUITE_data/printenv.bat @@ -0,0 +1 @@ +../httpd_SUITE_data/server_root/cgi-bin/printenv.bat
\ No newline at end of file diff --git a/lib/inets/test/httpd_basic_SUITE_data/printenv.sh b/lib/inets/test/httpd_basic_SUITE_data/printenv.sh new file mode 120000 index 0000000000..0136a3fa23 --- /dev/null +++ b/lib/inets/test/httpd_basic_SUITE_data/printenv.sh @@ -0,0 +1 @@ +../httpd_SUITE_data/server_root/cgi-bin/printenv.sh
\ No newline at end of file diff --git a/lib/inets/test/httpd_mod.erl b/lib/inets/test/httpd_mod.erl index df4ed6b179..7d3326fb65 100644 --- a/lib/inets/test/httpd_mod.erl +++ b/lib/inets/test/httpd_mod.erl @@ -842,6 +842,14 @@ cgi(Type, Port, Host, Node) -> {version, "HTTP/1.0"}]), %% tsp("cgi -> done"), + + %% Check "ScriptNoCache" directive (default: false) + ok = httpd_test_lib:verify_request(Type, Host, Port, Node, + "GET /cgi-bin/" ++ Script ++ + " HTTP/1.0\r\n\r\n", + [{statuscode, 200}, + {no_header, "cache-control"}, + {version, "HTTP/1.0"}]), ok. @@ -899,6 +907,13 @@ esi(Type, Port, Host, Node) -> " HTTP/1.0\r\n\r\n", [{statuscode, 302}, {version, "HTTP/1.0"}]), + %% Check "ErlScriptNoCache" directive (default: false) + ok = httpd_test_lib:verify_request(Type, Host, Port, Node, + "GET /cgi-bin/erl/httpd_example:get" + " HTTP/1.0\r\n\r\n", + [{statuscode, 200}, + {no_header, "cache-control"}, + {version, "HTTP/1.0"}]), ok. diff --git a/lib/inets/test/httpd_test_lib.erl b/lib/inets/test/httpd_test_lib.erl index 13584c50f6..3e82324a30 100644 --- a/lib/inets/test/httpd_test_lib.erl +++ b/lib/inets/test/httpd_test_lib.erl @@ -361,7 +361,7 @@ do_validate(Header, [{header, HeaderField, Value}|Rest],N,P) -> tsf({wrong_header_field_value, LowerHeaderField, Header}) end, do_validate(Header, Rest, N, P); -do_validate(Header,[{no_last_modified, HeaderField}|Rest],N,P) -> +do_validate(Header,[{no_header, HeaderField}|Rest],N,P) -> case lists:keysearch(HeaderField,1,Header) of {value,_} -> tsf({wrong_header_field_value, HeaderField, Header}); diff --git a/lib/kernel/doc/src/inet.xml b/lib/kernel/doc/src/inet.xml index 254dfbf034..fd62f778a2 100644 --- a/lib/kernel/doc/src/inet.xml +++ b/lib/kernel/doc/src/inet.xml @@ -722,6 +722,59 @@ fe80::204:acff:fe17:bf38 <p>Received <c>Packet</c> is delivered as defined by Mode.</p> </item> + <tag><c>{netns, Namespace :: file:filename_all()}</c></tag> + <item> + <p>Set a network namespace for the socket. The <c>Namespace</c> + parameter is a filename defining the namespace for example + <c>"/var/run/netns/example"</c> typically created by the command + <c>ip netns add example</c>. This option must be used in a + function call that creates a socket i.e + <seealso marker="gen_tcp#connect/3"> + gen_tcp:connect/3,4</seealso>, + <seealso marker="gen_tcp#listen/2"> + gen_tcp:listen/2</seealso>, + <seealso marker="gen_udp#open/1"> + gen_udp:open/1,2</seealso> or + <seealso marker="gen_sctp#open/0"> + gen_sctp:open/0-2</seealso>. + </p> + <p>This option uses the Linux specific syscall + <c>setns()</c> such as in Linux kernel 3.0 or later + and therefore only exists when the runtime system + has been compiled for such an operating system. + </p> + <p> + The virtual machine also needs elevated privileges either + running as superuser or (for Linux) having the capability + <c>CAP_SYS_ADMIN</c> according to the documentation for setns(2). + However, during testing also <c>CAP_SYS_PTRACE</c> + and <c>CAP_DAC_READ_SEARCH</c> has proven to be necessary. + Example:<code> +setcap cap_sys_admin,cap_sys_ptrace,cap_dac_read_search+epi beam.smp +</code> + Note also that the filesystem containing the virtual machine + executable (<c>beam.smp</c> in the example above) has to be local, + mounted without the <c>nosetuid</c> flag, + support extended attributes and that + the kernel has to support file capabilities. + All this runs out of the box on at least Ubuntu 12.04 LTS, + except that SCTP sockets appears to not support + network namespaces. + </p> + <p>The <c>Namespace</c> is a file name and is encoded + and decoded as discussed in + <seealso marker="file">file</seealso> + except that the emulator flag <c>+fnu</c> is ignored and + <seealso marker="#getopts/2">getopts/2</seealso> + for this option will return a binary for the filename + if the stored filename can not be decoded, + which should only happen if you set the option using a binary + that can not be decoded with the emulator's filename encoding: + <seealso marker="file#native_name_encoding/0"> + file:native_name_encoding/0</seealso>. + </p> + </item> + <tag><c>list</c></tag> <item> <p>Received <c>Packet</c> is delivered as a list.</p> diff --git a/lib/kernel/src/inet.erl b/lib/kernel/src/inet.erl index 5749027acd..27f085c3aa 100644 --- a/lib/kernel/src/inet.erl +++ b/lib/kernel/src/inet.erl @@ -200,7 +200,14 @@ send(Socket, Packet) -> Options :: [socket_setopt()]. setopts(Socket, Opts) -> - prim_inet:setopts(Socket, Opts). + SocketOpts = + [case Opt of + {netns,NS} -> + {netns,filename2binary(NS)}; + _ -> + Opt + end || Opt <- Opts], + prim_inet:setopts(Socket, SocketOpts). -spec getopts(Socket, Options) -> {'ok', OptionValues} | {'error', posix()} when @@ -209,7 +216,18 @@ setopts(Socket, Opts) -> OptionValues :: [socket_setopt()]. getopts(Socket, Opts) -> - prim_inet:getopts(Socket, Opts). + case prim_inet:getopts(Socket, Opts) of + {ok,OptionValues} -> + {ok, + [case OptionValue of + {netns,Bin} -> + {netns,binary2filename(Bin)}; + _ -> + OptionValue + end || OptionValue <- OptionValues]}; + Other -> + Other + end. -spec getifaddrs(Socket :: socket()) -> {'ok', [string()]} | {'error', posix()}. @@ -641,6 +659,14 @@ con_opt([Opt | Opts], R, As) -> {tcp_module,_} -> con_opt(Opts, R, As); inet -> con_opt(Opts, R, As); inet6 -> con_opt(Opts, R, As); + {netns,NS} -> + BinNS = filename2binary(NS), + case prim_inet:is_sockopt_val(netns, BinNS) of + true -> + con_opt(Opts, R#connect_opts { fd = [{netns,BinNS}] }, As); + false -> + {error, badarg} + end; {Name,Val} when is_atom(Name) -> con_add(Name, Val, R, Opts, As); _ -> {error, badarg} end; @@ -699,6 +725,14 @@ list_opt([Opt | Opts], R, As) -> {tcp_module,_} -> list_opt(Opts, R, As); inet -> list_opt(Opts, R, As); inet6 -> list_opt(Opts, R, As); + {netns,NS} -> + BinNS = filename2binary(NS), + case prim_inet:is_sockopt_val(netns, BinNS) of + true -> + list_opt(Opts, R#listen_opts { fd = [{netns,BinNS}] }, As); + false -> + {error, badarg} + end; {Name,Val} when is_atom(Name) -> list_add(Name, Val, R, Opts, As); _ -> {error, badarg} end; @@ -745,6 +779,14 @@ udp_opt([Opt | Opts], R, As) -> {udp_module,_} -> udp_opt(Opts, R, As); inet -> udp_opt(Opts, R, As); inet6 -> udp_opt(Opts, R, As); + {netns,NS} -> + BinNS = filename2binary(NS), + case prim_inet:is_sockopt_val(netns, BinNS) of + true -> + list_opt(Opts, R#udp_opts { fd = [{netns,BinNS}] }, As); + false -> + {error, badarg} + end; {Name,Val} when is_atom(Name) -> udp_add(Name, Val, R, Opts, As); _ -> {error, badarg} end; @@ -814,6 +856,17 @@ sctp_opt([Opt|Opts], Mod, R, As) -> {sctp_module,_} -> sctp_opt (Opts, Mod, R, As); % Done with inet -> sctp_opt (Opts, Mod, R, As); % Done with inet6 -> sctp_opt (Opts, Mod, R, As); % Done with + {netns,NS} -> + BinNS = filename2binary(NS), + case prim_inet:is_sockopt_val(netns, BinNS) of + true -> + sctp_opt( + Opts, Mod, + R#sctp_opts { fd = [{netns,BinNS}] }, + As); + false -> + {error, badarg} + end; {Name,Val} -> sctp_opt (Opts, Mod, R, As, Name, Val); _ -> {error,badarg} end; @@ -858,6 +911,39 @@ add_opt(Name, Val, Opts, As) -> end. +%% Passthrough all unknown - catch type errors later +filename2binary(List) when is_list(List) -> + OutEncoding = file:native_name_encoding(), + try unicode:characters_to_binary(List, unicode, OutEncoding) of + Bin when is_binary(Bin) -> + Bin; + _ -> + List + catch + error:badarg -> + List + end; +filename2binary(Bin) -> + Bin. + +binary2filename(Bin) -> + InEncoding = file:native_name_encoding(), + case unicode:characters_to_list(Bin, InEncoding) of + Filename when is_list(Filename) -> + Filename; + _ -> + %% For getopt/setopt of netns this should only happen if + %% a binary with wrong encoding was used when setting the + %% option, hence the user shall eat his/her own medicine. + %% + %% I.e passthrough here too for now. + %% Future usecases will most probably not want this, + %% rather Unicode error or warning + %% depending on emulator flag instead. + Bin + end. + + translate_ip(any, inet) -> {0,0,0,0}; translate_ip(loopback, inet) -> {127,0,0,1}; translate_ip(any, inet6) -> {0,0,0,0,0,0,0,0}; @@ -1070,7 +1156,7 @@ gethostbyaddr_tm_native(Addr, Timer, Opts) -> Result -> Result end. --spec open(Fd :: integer(), +-spec open(Fd_or_OpenOpts :: integer() | list(), Addr :: ip_address(), Port :: port_number(), Opts :: [socket_setopt()], @@ -1080,8 +1166,14 @@ gethostbyaddr_tm_native(Addr, Timer, Opts) -> Module :: atom()) -> {'ok', socket()} | {'error', posix()}. -open(Fd, Addr, Port, Opts, Protocol, Family, Type, Module) when Fd < 0 -> - case prim_inet:open(Protocol, Family, Type) of +open(FdO, Addr, Port, Opts, Protocol, Family, Type, Module) + when is_integer(FdO), FdO < 0; + is_list(FdO) -> + OpenOpts = + if is_list(FdO) -> FdO; + true -> [] + end, + case prim_inet:open(Protocol, Family, Type, OpenOpts) of {ok,S} -> case prim_inet:setopts(S, Opts) of ok -> @@ -1104,7 +1196,8 @@ open(Fd, Addr, Port, Opts, Protocol, Family, Type, Module) when Fd < 0 -> Error -> Error end; -open(Fd, _Addr, _Port, Opts, Protocol, Family, Type, Module) -> +open(Fd, _Addr, _Port, Opts, Protocol, Family, Type, Module) + when is_integer(Fd) -> fdopen(Fd, Opts, Protocol, Family, Type, Module). bindx(S, [Addr], Port0) -> diff --git a/lib/kernel/src/inet_int.hrl b/lib/kernel/src/inet_int.hrl index 67a99913a1..18a4a61b2f 100644 --- a/lib/kernel/src/inet_int.hrl +++ b/lib/kernel/src/inet_int.hrl @@ -143,6 +143,7 @@ -define(INET_LOPT_TCP_SEND_TIMEOUT_CLOSE, 35). -define(INET_LOPT_MSGQ_HIWTRMRK, 36). -define(INET_LOPT_MSGQ_LOWTRMRK, 37). +-define(INET_LOPT_NETNS, 38). % Specific SCTP options: separate range: -define(SCTP_OPT_RTOINFO, 100). -define(SCTP_OPT_ASSOCINFO, 101). diff --git a/lib/kernel/test/inet_SUITE.erl b/lib/kernel/test/inet_SUITE.erl index 46c8c0b88b..ed43749cc0 100644 --- a/lib/kernel/test/inet_SUITE.erl +++ b/lib/kernel/test/inet_SUITE.erl @@ -38,10 +38,10 @@ gethostnative_debug_level/0, gethostnative_debug_level/1, getif/1, getif_ifr_name_overflow/1,getservbyname_overflow/1, getifaddrs/1, - parse_strict_address/1]). + parse_strict_address/1, simple_netns/1]). -export([get_hosts/1, get_ipv6_hosts/1, parse_hosts/1, parse_address/1, - kill_gethost/0, parallell_gethost/0]). + kill_gethost/0, parallell_gethost/0, test_netns/0]). -export([init_per_testcase/2, end_per_testcase/2]). suite() -> [{ct_hooks,[ts_install_cth]}]. @@ -53,7 +53,7 @@ all() -> t_gethostnative, gethostnative_parallell, cname_loop, gethostnative_debug_level, gethostnative_soft_restart, getif, getif_ifr_name_overflow, getservbyname_overflow, - getifaddrs, parse_strict_address]. + getifaddrs, parse_strict_address, simple_netns]. groups() -> [{parse, [], [parse_hosts, parse_address]}]. @@ -1099,3 +1099,96 @@ toupper([C|Cs]) when is_integer(C) -> end; toupper([]) -> []. + + +simple_netns(Config) when is_list(Config) -> + {ok,U} = gen_udp:open(0), + case inet:setopts(U, [{netns,""}]) of + ok -> + jog_netns_opt(U), + ok = gen_udp:close(U), + %% + {ok,L} = gen_tcp:listen(0, []), + jog_netns_opt(L), + ok = gen_tcp:close(L), + %% + {ok,S} = gen_sctp:open(), + jog_netns_opt(S), + ok = gen_sctp:close(S); + {error,einval} -> + {skip,"setns() not supported"} + end. + +jog_netns_opt(S) -> + %% This is just jogging the option mechanics + ok = inet:setopts(S, [{netns,""}]), + {ok,[{netns,""}]} = inet:getopts(S, [netns]), + ok = inet:setopts(S, [{netns,"/proc/self/ns/net"}]), + {ok,[{netns,"/proc/self/ns/net"}]} = inet:getopts(S, [netns]), + ok. + + +%% Manual test to be run outside test_server in an emulator +%% started by root, in a machine with setns() support... +test_netns() -> + DefaultIF = v1, + DefaultIP = {192,168,1,17}, + Namespace = "test", + NamespaceIF = v2, + NamespaceIP = {192,168,1,18}, + %% + DefaultIPString = inet_parse:ntoa(DefaultIP), + NamespaceIPString = inet_parse:ntoa(NamespaceIP), + cmd("ip netns add ~s", + [Namespace]), + cmd("ip link add name ~w type veth peer name ~w netns ~s", + [DefaultIF,NamespaceIF,Namespace]), + cmd("ip netns exec ~s ip addr add ~s/30 dev ~w", + [Namespace,NamespaceIPString,NamespaceIF]), + cmd("ip netns exec ~s ip link set ~w up", + [Namespace,NamespaceIF]), + cmd("ip addr add ~s/30 dev ~w", + [DefaultIPString,DefaultIF]), + cmd("ip link set ~w up", + [DefaultIF]), + try test_netns( + {DefaultIF,DefaultIP}, + filename:join("/var/run/netns/", Namespace), + {NamespaceIF,NamespaceIP}) of + Result -> + io:put_chars(["#### Test done",io_lib:nl()]), + Result + after + cmd("ip link delete ~w type veth", + [DefaultIF]), + cmd("ip netns delete ~s", + [Namespace]) + end. + +test_netns({DefaultIF,DefaultIP}, Namespace, {NamespaceIF,NamespaceIP}) -> + {ok,ListenSocket} = gen_tcp:listen(0, [{active,false}]), + {ok,[{addr,DefaultIP}]} = inet:ifget(ListenSocket, DefaultIF, [addr]), + {ok,ListenPort} = inet:port(ListenSocket), + {ok,ConnectSocket} = + gen_tcp:connect( + DefaultIP, ListenPort, [{active,false},{netns,Namespace}], 3000), + {ok,[{addr,NamespaceIP}]} = inet:ifget(ConnectSocket, NamespaceIF, [addr]), + {ok,ConnectPort} = inet:port(ConnectSocket), + {ok,AcceptSocket} = gen_tcp:accept(ListenSocket, 0), + {ok,AcceptPort} = inet:port(AcceptSocket), + {ok,{NamespaceIP,ConnectPort}} = inet:peername(AcceptSocket), + {ok,{DefaultIP,AcceptPort}} = inet:peername(ConnectSocket), + ok = gen_tcp:send(ConnectSocket, "data"), + ok = gen_tcp:close(ConnectSocket), + {ok,"data"} = gen_tcp:recv(AcceptSocket, 4, 1000), + {error,closed} = gen_tcp:recv(AcceptSocket, 1, 1000), + ok = gen_tcp:close(AcceptSocket), + ok = gen_tcp:close(ListenSocket). + +cmd(Cmd, Args) -> + cmd(io_lib:format(Cmd, Args)). +%% +cmd(CmdString) -> + io:put_chars(["# ",CmdString,io_lib:nl()]), + io:put_chars([os:cmd(CmdString++" ; echo ' =>' $?")]), + ok. diff --git a/lib/odbc/test/odbc_connect_SUITE.erl b/lib/odbc/test/odbc_connect_SUITE.erl index 74ae2c96e6..2a16388929 100644 --- a/lib/odbc/test/odbc_connect_SUITE.erl +++ b/lib/odbc/test/odbc_connect_SUITE.erl @@ -77,6 +77,8 @@ end_per_group(_GroupName, Config) -> %% variable, but should NOT alter/remove any existing entries. %%-------------------------------------------------------------------- init_per_suite(Config) when is_list(Config) -> + file:write_file(filename:join([proplists:get_value(priv_dir,Config), + "..","..","..","ignore_core_files"]),""), case odbc_test_lib:skip() of true -> {skip, "ODBC not supported"}; diff --git a/lib/os_mon/c_src/Makefile.in b/lib/os_mon/c_src/Makefile.in index 51569f6ec9..f84ccf7c87 100644 --- a/lib/os_mon/c_src/Makefile.in +++ b/lib/os_mon/c_src/Makefile.in @@ -84,6 +84,7 @@ debug opt: $(TARGET_FILES) clean: rm -f $(TARGET_FILES) + rm -rf $(OBJDIR) rm -f core *~ docs: diff --git a/lib/os_mon/c_src/cpu_sup.c b/lib/os_mon/c_src/cpu_sup.c index 7372d5b0e8..e9fd75a32c 100644 --- a/lib/os_mon/c_src/cpu_sup.c +++ b/lib/os_mon/c_src/cpu_sup.c @@ -29,6 +29,7 @@ #include <stdio.h> #include <stdlib.h> #include <unistd.h> +#include <string.h> #if defined(__sun__) #include <kstat.h> @@ -120,7 +121,9 @@ typedef struct { static void util_measure(unsigned int **result_vec, int *result_sz); +#if defined(__sun__) static unsigned int misc_measure(char* name); +#endif static void send(unsigned int data); static void sendv(unsigned int data[], int ints); static void error(char* err_msg); @@ -140,7 +143,9 @@ int main(int argc, char** argv) { int rc; int sz; unsigned int *rv; +#if defined(__linux__) unsigned int no_of_cpus = 0; +#endif #if defined(__sun__) kstat_ctl = kstat_open(); @@ -288,10 +293,10 @@ static unsigned int misc_measure(char* name) { if(!entry) return -1; - if(entry->data_type != KSTAT_DATA_ULONG) + if(entry->data_type != KSTAT_DATA_UINT32) return -1; - return entry->value.ul; + return entry->value.ui32; } diff --git a/lib/os_mon/test/cpu_sup_SUITE.erl b/lib/os_mon/test/cpu_sup_SUITE.erl index d04adbb6d3..e0382cb0c7 100644 --- a/lib/os_mon/test/cpu_sup_SUITE.erl +++ b/lib/os_mon/test/cpu_sup_SUITE.erl @@ -88,6 +88,7 @@ load_api(Config) when is_list(Config) -> ?line N = cpu_sup:nprocs(), ?line true = is_integer(N), ?line true = N>0, + ?line true = N<1000000, %% avg1() ?line Load1 = cpu_sup:avg1(), diff --git a/lib/parsetools/doc/src/leex.xml b/lib/parsetools/doc/src/leex.xml index d5c24c303d..b4e2af6857 100644 --- a/lib/parsetools/doc/src/leex.xml +++ b/lib/parsetools/doc/src/leex.xml @@ -4,7 +4,7 @@ <erlref> <header> <copyright> - <year>2009</year><year>2011</year> + <year>2009</year><year>2013</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -38,19 +38,21 @@ Token = tuple()</code> </section> <funcs> <func> - <name>file(FileName) -> ok | error</name> - <name>file(FileName, Options) -> ok | error</name> + <name>file(FileName, [, Options]) -> LeexRet</name> <fsummary>Generate a lexical analyzer</fsummary> <type> <v>FileName = filename()</v> <v>Options = Option | [Option]</v> <v>Option = - see below -</v> - <v>FileReturn = {ok, Scannerfile} - | {ok, Scannerfile, Warnings} - | error - | {error, Warnings, Errors}</v> + <v>LeexRet = {ok, Scannerfile} + | {ok, Scannerfile, Warnings} + | error + | {error, Warnings, Errors}</v> <v>Scannerfile = filename()</v> <v>Warnings = Errors = [{filename(), [ErrorInfo]}]</v> + <v>ErrorInfo = {ErrorLine, module(), Reason}</v> + <v>ErrorLine = integer()</v> + <v>Reason = - formatable by format_error/1 -</v> </type> <desc> <p>Generates a lexical analyzer from the definition in the input diff --git a/lib/parsetools/src/leex.erl b/lib/parsetools/src/leex.erl index e531b78a5b..7039aea1ae 100644 --- a/lib/parsetools/src/leex.erl +++ b/lib/parsetools/src/leex.erl @@ -1645,10 +1645,14 @@ output_encoding_comment(File, #leex{encoding = Encoding}) -> output_file_directive(File, Filename, Line) -> io:fwrite(File, <<"-file(~ts, ~w).\n">>, - [format_filename(Filename), Line]). + [format_filename(Filename, File), Line]). -format_filename(Filename) -> - io_lib:write_string(filename:flatten(Filename)). +format_filename(Filename0, File) -> + Filename = filename:flatten(Filename0), + case lists:keyfind(encoding, 1, io:getopts(File)) of + {encoding, unicode} -> io_lib:write_string(Filename); + _ -> io_lib:write_string_as_latin1(Filename) + end. quote($^) -> "\\^"; quote($.) -> "\\."; diff --git a/lib/parsetools/src/yecc.erl b/lib/parsetools/src/yecc.erl index f9207d926e..b698beb558 100644 --- a/lib/parsetools/src/yecc.erl +++ b/lib/parsetools/src/yecc.erl @@ -482,7 +482,7 @@ generate(St0) -> F = case member(time, St1#yecc.options) of true -> io:fwrite(<<"Generating parser from grammar in ~ts\n">>, - [format_filename(St1#yecc.infile)]), + [format_filename(St1#yecc.infile, St1)]), fun timeit/3; false -> fun(_Name, Fn, St) -> Fn(St) end @@ -2519,7 +2519,7 @@ output_encoding_comment(#yecc{encoding = Encoding}=St) -> output_file_directive(St, Filename, Line) when St#yecc.file_attrs -> fwrite(St, <<"-file(~ts, ~w).\n">>, - [format_filename(Filename), Line]); + [format_filename(Filename, St), Line]); output_file_directive(St, _Filename, _Line) -> St. @@ -2547,8 +2547,12 @@ nl(#yecc{outport = Outport, line = Line}=St) -> io:nl(Outport), St#yecc{line = Line + 1}. -format_filename(Filename) -> - io_lib:write_string(filename:flatten(Filename)). +format_filename(Filename0, St) -> + Filename = filename:flatten(Filename0), + case lists:keyfind(encoding, 1, io:getopts(St#yecc.outport)) of + {encoding, unicode} -> io_lib:write_string(Filename); + _ -> io_lib:write_string_as_latin1(Filename) + end. format_assoc(left) -> "Left"; diff --git a/lib/parsetools/test/leex_SUITE.erl b/lib/parsetools/test/leex_SUITE.erl index afedd79a4e..7cbc72accb 100644 --- a/lib/parsetools/test/leex_SUITE.erl +++ b/lib/parsetools/test/leex_SUITE.erl @@ -45,7 +45,7 @@ pt/1, man/1, ex/1, ex2/1, not_yet/1, - otp_10302/1]). + otp_10302/1, otp_11286/1]). % Default timetrap timeout (set in init_per_testcase). -define(default_timeout, ?t:minutes(1)). @@ -67,7 +67,7 @@ all() -> groups() -> [{checks, [], [file, compile, syntax]}, {examples, [], [pt, man, ex, ex2, not_yet]}, - {tickets, [], [otp_10302]}]. + {tickets, [], [otp_10302, otp_11286]}]. init_per_suite(Config) -> Config. @@ -983,6 +983,68 @@ otp_10302(Config) when is_list(Config) -> ok. +otp_11286(doc) -> + "OTP-11286. A Unicode filename bug; both Leex and Yecc."; +otp_11286(suite) -> []; +otp_11286(Config) when is_list(Config) -> + Node = start_node(otp_11286, "+fnu"), + Dir = ?privdir, + UName = [1024] ++ "u", + UDir = filename:join(Dir, UName), + ok = rpc:call(Node, file, make_dir, [UDir]), + + %% Note: Cannot use UName as filename since the filename is used + %% as module name. To be fixed in R18. + Filename = filename:join(UDir, 'OTP-11286.xrl'), + Scannerfile = filename:join(UDir, 'OTP-11286.erl'), + Options = [return, {scannerfile, Scannerfile}], + + Mini1 = <<"%% coding: utf-8\n" + "Definitions.\n" + "D = [0-9]\n" + "Rules.\n" + "{L}+ : {token,{word,TokenLine,TokenChars}}.\n" + "Erlang code.\n">>, + ok = rpc:call(Node, file, write_file, [Filename, Mini1]), + {ok, _, []} = rpc:call(Node, leex, file, [Filename, Options]), + {ok,_,_} = rpc:call(Node, compile, file, + [Scannerfile,[basic_validation,return]]), + + Mini2 = <<"Definitions.\n" + "D = [0-9]\n" + "Rules.\n" + "{L}+ : {token,{word,TokenLine,TokenChars}}.\n" + "Erlang code.\n">>, + ok = rpc:call(Node, file, write_file, [Filename, Mini2]), + {ok, _, []} = rpc:call(Node, leex, file, [Filename, Options]), + {ok,_,_} = rpc:call(Node, compile, file, + [Scannerfile,[basic_validation,return]]), + + Mini3 = <<"%% coding: latin-1\n" + "Definitions.\n" + "D = [0-9]\n" + "Rules.\n" + "{L}+ : {token,{word,TokenLine,TokenChars}}.\n" + "Erlang code.\n">>, + ok = rpc:call(Node, file, write_file, [Filename, Mini3]), + {ok, _, []} = rpc:call(Node, leex, file, [Filename, Options]), + {ok,_,_} = rpc:call(Node, compile, file, + [Scannerfile,[basic_validation,return]]), + + true = test_server:stop_node(Node), + ok. + +start_node(Name, Args) -> + [_,Host] = string:tokens(atom_to_list(node()), "@"), + ct:log("Trying to start ~w@~s~n", [Name,Host]), + case test_server:start_node(Name, peer, [{args,Args}]) of + {error,Reason} -> + test_server:fail(Reason); + {ok,Node} -> + ct:log("Node ~p started~n", [Node]), + Node + end. + unwritable(Fname) -> {ok, Info} = file:read_file_info(Fname), Mode = Info#file_info.mode - 8#00200, diff --git a/lib/parsetools/test/yecc_SUITE.erl b/lib/parsetools/test/yecc_SUITE.erl index 9c865a1ec6..c7ac9fd232 100644 --- a/lib/parsetools/test/yecc_SUITE.erl +++ b/lib/parsetools/test/yecc_SUITE.erl @@ -49,7 +49,8 @@ otp_5369/1, otp_6362/1, otp_7945/1, otp_8483/1, otp_8486/1, - otp_7292/1, otp_7969/1, otp_8919/1, otp_10302/1, otp_11269/1]). + otp_7292/1, otp_7969/1, otp_8919/1, otp_10302/1, otp_11269/1, + otp_11286/1]). % Default timetrap timeout (set in init_per_testcase). -define(default_timeout, ?t:minutes(1)). @@ -77,7 +78,7 @@ groups() -> {bugs, [], [otp_5369, otp_6362, otp_7945, otp_8483, otp_8486]}, {improvements, [], [otp_7292, otp_7969, otp_8919, otp_10302, - otp_11269]}]. + otp_11269, otp_11286]}]. init_per_suite(Config) -> Config. @@ -1996,6 +1997,64 @@ otp_11269(Config) when is_list(Config) -> {ok,'OTP-11269',_Warnings} = compile:file(ErlFile, Opts), ok. +otp_11286(doc) -> + "OTP-11286. A Unicode filename bug; both Leex and Yecc."; +otp_11286(suite) -> []; +otp_11286(Config) when is_list(Config) -> + Node = start_node(otp_11286, "+fnu"), + Dir = ?privdir, + UName = [1024] ++ "u", + UDir = filename:join(Dir, UName), + ok = rpc:call(Node, file, make_dir, [UDir]), + + %% Note: Cannot use UName as filename since the filename is used + %% as module name. To be fixed in R18. + Filename = filename:join(UDir, 'OTP-11286.yrl'), + Ret = [return, {report, false}, time], + + Mini1 = <<"%% coding: utf-8 + Terminals t. + Nonterminals nt. + Rootsymbol nt. + nt -> t.">>, + ok = rpc:call(Node, file, write_file, [Filename, Mini1]), + {ok,ErlFile,[]} = rpc:call(Node, yecc, file, [Filename, Ret]), + Opts = [return, warn_unused_vars,{outdir,Dir}], + {ok,_,_Warnings} = rpc:call(Node, compile, file, [ErlFile, Opts]), + + Mini2 = <<"Terminals t. + Nonterminals nt. + Rootsymbol nt. + nt -> t.">>, + ok = rpc:call(Node, file, write_file, [Filename, Mini2]), + {ok,ErlFile,[]} = rpc:call(Node, yecc, file, [Filename, Ret]), + Opts = [return, warn_unused_vars,{outdir,Dir}], + {ok,_,_Warnings} = rpc:call(Node, compile, file, [ErlFile, Opts]), + + Mini3 = <<"%% coding: latin-1 + Terminals t. + Nonterminals nt. + Rootsymbol nt. + nt -> t.">>, + ok = rpc:call(Node, file, write_file, [Filename, Mini3]), + {ok,ErlFile,[]} = rpc:call(Node, yecc, file, [Filename, Ret]), + Opts = [return, warn_unused_vars,{outdir,Dir}], + {ok,_,_Warnings} = rpc:call(Node, compile, file, [ErlFile, Opts]), + + true = test_server:stop_node(Node), + ok. + +start_node(Name, Args) -> + [_,Host] = string:tokens(atom_to_list(node()), "@"), + ct:log("Trying to start ~w@~s~n", [Name,Host]), + case test_server:start_node(Name, peer, [{args,Args}]) of + {error,Reason} -> + test_server:fail(Reason); + {ok,Node} -> + ct:log("Node ~p started~n", [Node]), + Node + end. + yeccpre_size() -> yeccpre_size(default_yeccpre()). diff --git a/lib/public_key/asn1/PKCS-7.asn1 b/lib/public_key/asn1/PKCS-7.asn1 index a6dfd57d80..e76f928acb 100644 --- a/lib/public_key/asn1/PKCS-7.asn1 +++ b/lib/public_key/asn1/PKCS-7.asn1 @@ -78,6 +78,49 @@ signingTime ATTRIBUTE ::= { SigningTime ::= Time -- imported from ISO/IEC 9594-8 +-- begin added for VCE SCEP-support +transactionID ATTRIBUTE ::= { + WITH SYNTAX PrintableString + ID id-transId +} + +messageType ATTRIBUTE ::= { + WITH SYNTAX PrintableString + ID id-messageType +} + +pkiStatus ATTRIBUTE ::= { + WITH SYNTAX PrintableString + ID id-pkiStatus +} + +failInfo ATTRIBUTE ::= { + WITH SYNTAX PrintableString + ID id-failInfo +} + +senderNonce ATTRIBUTE ::= { + WITH SYNTAX OCTET STRING + ID id-senderNonce +} + +recipientNonce ATTRIBUTE ::= { + WITH SYNTAX OCTET STRING + ID id-recipientNonce +} + +-- This is the authenticatedAttributes -member from SignerInfo +-- added here to generate decode/encode functions for it which are +-- needed to build the pkcs-7 used by SCEP, the resulting encoding are +-- used to make a signed digest +SignerInfoAuthenticatedAttributes ::= CHOICE { + aaSet [0] IMPLICIT SET OF AttributePKCS-7 {{Authenticated}}, + aaSequence [2] EXPLICIT SEQUENCE OF AttributePKCS-7 {{Authenticated}} + -- Explicit because easier to compute digest on sequence of attributes and then reuse + -- encoded sequence in aaSequence. + } +-- end added for VCE SCEP-support + -- Also defined in X.509 -- Redeclared here as a parameterized type @@ -224,12 +267,9 @@ SignerInfo ::= SEQUENCE { issuerAndSerialNumber IssuerAndSerialNumber, digestAlgorithm DigestAlgorithmIdentifier, - authenticatedAttributes CHOICE { - aaSet [0] IMPLICIT SET OF AttributePKCS-7 {{Authenticated}}, - aaSequence [2] EXPLICIT SEQUENCE OF AttributePKCS-7 {{Authenticated}} - -- Explicit because easier to compute digest on sequence of attributes and then reuse - -- encoded sequence in aaSequence. - } OPTIONAL, + -- Added explicit type for authenticatedAttributes to be able to + -- encode/decode this type separately + authenticatedAttributes SignerInfoAuthenticatedAttributes OPTIONAL, digestEncryptionAlgorithm DigestEncryptionAlgorithmIdentifier, encryptedDigest EncryptedDigest, @@ -247,7 +287,15 @@ SignerInfo ::= SEQUENCE { Authenticated ATTRIBUTE ::= { contentType | - messageDigest, + messageDigest | +-- begin added for VCE SCEP-support + transactionID | + messageType | + pkiStatus | + failInfo | + senderNonce | + recipientNonce, +-- end added for VCE SCEP-support ..., -- add application-specific attributes here signingTime } @@ -384,4 +432,18 @@ signedAndEnvelopedData OBJECT IDENTIFIER ::= { pkcs-7 4 } digestedData OBJECT IDENTIFIER ::= { pkcs-7 5 } encryptedData OBJECT IDENTIFIER ::= { pkcs-7 6 } +-- begin added for VCE SCEP-support +id-VeriSign OBJECT IDENTIFIER ::= {2 16 us(840) 1 veriSign(113733)} +id-pki OBJECT IDENTIFIER ::= {id-VeriSign pki(1)} +id-attributes OBJECT IDENTIFIER ::= {id-pki attributes(9)} +id-messageType OBJECT IDENTIFIER ::= {id-attributes messageType(2)} +id-pkiStatus OBJECT IDENTIFIER ::= {id-attributes pkiStatus(3)} +id-failInfo OBJECT IDENTIFIER ::= {id-attributes failInfo(4)} +id-senderNonce OBJECT IDENTIFIER ::= {id-attributes senderNonce(5)} +id-recipientNonce OBJECT IDENTIFIER ::= {id-attributes recipientNonce(6)} +id-transId OBJECT IDENTIFIER ::= {id-attributes transId(7)} +id-extensionReq OBJECT IDENTIFIER ::= {id-attributes extensionReq(8)} +-- end added for VCE SCEP-support + + END diff --git a/lib/public_key/src/pubkey_pbe.erl b/lib/public_key/src/pubkey_pbe.erl index 6f0be53db9..460624163b 100644 --- a/lib/public_key/src/pubkey_pbe.erl +++ b/lib/public_key/src/pubkey_pbe.erl @@ -66,7 +66,13 @@ decode(Data, Password,"DES-EDE3-CBC" = Cipher, KeyDevParams) -> decode(Data, Password,"RC2-CBC"= Cipher, KeyDevParams) -> {Key, IV} = password_to_key_and_iv(Password, Cipher, KeyDevParams), - crypto:block_decrypt(rc2_cbc, Key, IV, Data). + crypto:block_decrypt(rc2_cbc, Key, IV, Data); + +decode(Data, Password,"AES-128-CBC"= Cipher, IV) -> + %% PKCS5_SALT_LEN is 8 bytes + <<Salt:8/binary,_/binary>> = IV, + {Key, _} = password_to_key_and_iv(Password, Cipher, Salt), + crypto:block_decrypt(aes_cbc128, Key, IV, Data). %%-------------------------------------------------------------------- -spec pbdkdf1(string(), iodata(), integer(), atom()) -> binary(). @@ -200,7 +206,9 @@ derived_key_length(Cipher,_) when (Cipher == ?'rc2CBC') or 16; derived_key_length(Cipher,_) when (Cipher == ?'des-EDE3-CBC') or (Cipher == "DES-EDE3-CBC") -> - 24. + 24; +derived_key_length(Cipher,_) when (Cipher == "AES-128-CBC") -> + 16. cipher(#'PBES2-params_encryptionScheme'{algorithm = ?'desCBC'}) -> "DES-CBC"; diff --git a/lib/public_key/src/public_key.erl b/lib/public_key/src/public_key.erl index cdbfe6e07c..a4b6b8ad15 100644 --- a/lib/public_key/src/public_key.erl +++ b/lib/public_key/src/public_key.erl @@ -118,6 +118,13 @@ pem_entry_decode({Asn1Type, CryptDer, {Cipher, Salt}} = PemEntry, is_list(Cipher) andalso is_binary(Salt) andalso erlang:byte_size(Salt) == 8 -> + do_pem_entry_decode(PemEntry, Password); +pem_entry_decode({Asn1Type, CryptDer, {"AES-128-CBC"=Cipher, IV}} = PemEntry, + Password) when is_atom(Asn1Type) andalso + is_binary(CryptDer) andalso + is_list(Cipher) andalso + is_binary(IV) andalso + erlang:byte_size(IV) == 16 -> do_pem_entry_decode(PemEntry, Password). %%-------------------------------------------------------------------- diff --git a/lib/public_key/test/pbe_SUITE.erl b/lib/public_key/test/pbe_SUITE.erl index 2c9b17478d..b68ffbd5fd 100644 --- a/lib/public_key/test/pbe_SUITE.erl +++ b/lib/public_key/test/pbe_SUITE.erl @@ -218,6 +218,14 @@ encrypted_private_key_info(Config) when is_list(Config) -> [{'PrivateKeyInfo', _, {"RC2-CBC",_}} = PubEntry2] = PemRc2Entry, KeyInfo = public_key:pem_entry_decode(PubEntry2, "password"), + %% key generated with ssh-keygen -N hello_aes -f aes_128_cbc_enc_key + {ok, PemAesCbc} = file:read_file(filename:join(Datadir, "aes_128_cbc_enc_key")), + + PemAesCbcEntry = public_key:pem_decode(PemAesCbc), + ct:print("Pem entry: ~p" , [PemAesCbcEntry]), + [{'RSAPrivateKey', _, {"AES-128-CBC",_}} = PubAesCbcEntry] = PemAesCbcEntry, + #'RSAPrivateKey'{} = public_key:pem_entry_decode(PubAesCbcEntry, "hello_aes"), + check_key_info(KeyInfo). diff --git a/lib/public_key/test/pbe_SUITE_data/aes_128_cbc_enc_key b/lib/public_key/test/pbe_SUITE_data/aes_128_cbc_enc_key new file mode 100644 index 0000000000..34c7543f30 --- /dev/null +++ b/lib/public_key/test/pbe_SUITE_data/aes_128_cbc_enc_key @@ -0,0 +1,30 @@ +-----BEGIN RSA PRIVATE KEY----- +Proc-Type: 4,ENCRYPTED +DEK-Info: AES-128-CBC,D64FF97327558643763BE17BD50FDDAD + +oS4LbrLbQHPxfQILHl0KPswnkC1QqJ4RX6SkcQGVoYJJkPcavupABDYD1PSJf/MD +aPiN2OHsYAFLHxa1NGEAH6wKSvgdUJyaQ6jbSBNh9we9p2i3tpMnWsJMCZzXsCQh +RJj23/cFhb2UsqPM3OH6x6/VxX5VmD9Dnt1iU9b+WS6KdU45zP+QWpRd54uBrFab +Pw0kW7o84VFH6ahUDnzT8JUIk4P4G43G2F7wrOCbiK6AS0S8sCh5E83MrGEoJ6jB +NIW4xnLdBOLeV65NTgwWEn7bjLz+8IYSg2/wodjj5GL/ciMgiF+/krdQhzbHJhcm +dXV3SB/lTyjYUUGYU/3wm10f0iLJLFZxVU70yfV0eKhdYtWdR+2RxZjHvstBTGoI +BMtcaGwfMBh3wBHjS2M9AVh35DUYQIGW6QATf1VF+chhgESj6Qktkmfe4R9uAhP0 +r8Qkql/lq19K653c6ZIcUIYWvpAQ4Y/Q6Fdd92GY45FQdXYlZ/dXkwdq+ZYAhe6g +GUNmpwHf5N2a6lgXR3YytPYdhQbYMdy29RjXJsFWJh3sKTxgG/Y+FX2Ua7J1G4IW +wO6yZgQc9GyYzNn1TpT/TQ32GuHbw0u/oQqbNOJEjE0BTsQelEPpnNnEmkgPqSlI +3PNtsBvS6antvJ3CiCnmkQlT7/dLR9ym8nU+jo/hrtIStNUrdopCLB4+iUt7tJdz +jpW3Kc5fWmnGbp1UOXHoOghENfjIN+yUxIx9qCgBmWliY1nncUgzEHM34eGqGdek +nf6PowS4gIbJmO5Uc+0MwPld5HFou21da2M48FKolp3+CO1mX5MhvMLGVoFqNiE3 +dXYJG4bcMdxZncdaMn+c6ycA9iFTufF/qZPF/rGO5I+gc9M50bJjewbixqXM/LJ5 +1OnP/x7DN1Td3PTjAfjFX9yLWRMIjbihG43Htk5bOifaBtnOYj1e7WMjN8uBx91x +OCnfC3rngF4B9WmdYEkEvp9QZixbDlp0oh6/4HiRjjDkUfADnKuU/At7dd8sDOGD +NgaWVskJsulp8d9s3CozM7LmowlNpHV9BvAguckx/B7ZqV10mgAKOqZKk4LDlu2Y +MgQvSLJfyJsz/1q4z4jcXhYtSuZXXHk9lX9dgCZbQfVGnlsptNuV5KwupV2cz0Vi +Uh1mwvDXWFNIFwexZi0z27FJ1pKAKK+sf/GFqoAvdmYgYS6d5bmxh68bGZMZ2C6P +eehHkEZm1pv4CVDxrUTk+bNtqhDXglSdfxR0Xm1QDN95hM0dHq1kDZH6HgD6krJ6 +BBfd7mPRExH3+5JSQXoSUDO8LqP5phxLWKS0B8HDburnP/x9QzBOIKvmtDF1lQEk +FAI/6Lv8GJ0R7WYd2vFfGeqS94iw1BpmO/xS6WINOFpfwVCBuuYmLEdEWcXJgvy9 +zyaTX/mk1RMXo7I1X7aWviaIF7ykGxs1dJdrxQonwJ3oyTySNl2xf8bziKlqB/Ml +LDjeMNX91G8fJE0MdKPWd94PUoLN0CutM5sY5yHzwCvJQV9oQ1qvrQYUbnvtCEyQ +xT+bawt+ODgVb/QnyNeiIyEN5lXc8meJFLr1uMeEwX8WaJ7/KBKGk1V0XqVZTmga +-----END RSA PRIVATE KEY----- diff --git a/lib/public_key/test/public_key_SUITE.erl b/lib/public_key/test/public_key_SUITE.erl index c3aa2e2366..f8d167e770 100644 --- a/lib/public_key/test/public_key_SUITE.erl +++ b/lib/public_key/test/public_key_SUITE.erl @@ -46,7 +46,7 @@ all() -> groups() -> [{pem_decode_encode, [], [dsa_pem, rsa_pem, encrypted_pem, - dh_pem, cert_pem, pkcs10_pem]}, + dh_pem, cert_pem, pkcs7_pem, pkcs10_pem]}, {ssh_public_key_decode_encode, [], [ssh_rsa_public_key, ssh_dsa_public_key, ssh_rfc4716_rsa_comment, ssh_rfc4716_dsa_comment, ssh_rfc4716_rsa_subject, ssh_known_hosts, @@ -188,15 +188,9 @@ dh_pem() -> [{doc, "DH parametrs PEM-file decode/encode"}]. dh_pem(Config) when is_list(Config) -> Datadir = ?config(data_dir, Config), - [{'DHParameter', DerDH, not_encrypted} = Entry] = + [{'DHParameter', _DerDH, not_encrypted} = Entry] = erl_make_certs:pem_to_der(filename:join(Datadir, "dh.pem")), - - erl_make_certs:der_to_pem(filename:join(Datadir, "new_dh.pem"), [Entry]), - - DHParameter = public_key:der_decode('DHParameter', DerDH), - DHParameter = public_key:pem_entry_decode(Entry), - - Entry = public_key:pem_entry_encode('DHParameter', DHParameter). + asn1_encode_decode(Entry). %%-------------------------------------------------------------------- @@ -204,57 +198,38 @@ pkcs10_pem() -> [{doc, "PKCS-10 PEM-file decode/encode"}]. pkcs10_pem(Config) when is_list(Config) -> Datadir = ?config(data_dir, Config), - [{'CertificationRequest', DerPKCS10, not_encrypted} = Entry] = + [{'CertificationRequest', _DerPKCS10, not_encrypted} = Entry] = erl_make_certs:pem_to_der(filename:join(Datadir, "req.pem")), - - erl_make_certs:der_to_pem(filename:join(Datadir, "new_req.pem"), [Entry]), - - PKCS10 = public_key:der_decode('CertificationRequest', DerPKCS10), - PKCS10 = public_key:pem_entry_decode(Entry), - - Entry = public_key:pem_entry_encode('CertificationRequest', PKCS10). - + asn1_encode_decode(Entry). %%-------------------------------------------------------------------- pkcs7_pem() -> [{doc, "PKCS-7 PEM-file decode/encode"}]. pkcs7_pem(Config) when is_list(Config) -> Datadir = ?config(data_dir, Config), - [{'ContentInfo', DerPKCS7, not_encrypted} = Entry] = + [{'ContentInfo', _, not_encrypted} = Entry0] = erl_make_certs:pem_to_der(filename:join(Datadir, "pkcs7_cert.pem")), - - erl_make_certs:der_to_pem(filename:join(Datadir, "new_pkcs7_cert.pem"), [Entry]), - - PKCS7 = public_key:der_decode('ContentInfo', DerPKCS7), - PKCS7 = public_key:pem_entry_decode(Entry), - - Entry = public_key:pem_entry_encode('ContentInfo', PKCS7). - + [{'ContentInfo', _, not_encrypted} = Entry1] = + erl_make_certs:pem_to_der(filename:join(Datadir, "pkcs7_ext.pem")), + asn1_encode_decode(Entry0), + asn1_encode_decode(Entry1). + %%-------------------------------------------------------------------- cert_pem() -> [{doc, "Certificate PEM-file decode/encode"}]. cert_pem(Config) when is_list(Config) -> Datadir = ?config(data_dir, Config), - - [Entry0] = - erl_make_certs:pem_to_der(filename:join(Datadir, "dsa.pem")), - - [{'Certificate', DerCert, not_encrypted} = Entry7] = + + [{'Certificate', _, not_encrypted} = Entry0] = erl_make_certs:pem_to_der(filename:join(Datadir, "client_cert.pem")), - Cert = public_key:der_decode('Certificate', DerCert), - Cert = public_key:pem_entry_decode(Entry7), + asn1_encode_decode(Entry0), - CertEntries = [{'Certificate', _, not_encrypted} = CertEntry0, - {'Certificate', _, not_encrypted} = CertEntry1] = + [{'Certificate', _, not_encrypted} = Entry1, + {'Certificate', _, not_encrypted} = Entry2] = erl_make_certs:pem_to_der(filename:join(Datadir, "cacerts.pem")), - - ok = erl_make_certs:der_to_pem(filename:join(Datadir, "wcacerts.pem"), CertEntries), - ok = erl_make_certs:der_to_pem(filename:join(Datadir, "wdsa.pem"), [Entry0]), - NewCertEntries = erl_make_certs:pem_to_der(filename:join(Datadir, "wcacerts.pem")), - true = lists:member(CertEntry0, NewCertEntries), - true = lists:member(CertEntry1, NewCertEntries), - [Entry0] = erl_make_certs:pem_to_der(filename:join(Datadir, "wdsa.pem")). + asn1_encode_decode(Entry1), + asn1_encode_decode(Entry2). %%-------------------------------------------------------------------- ssh_rsa_public_key() -> @@ -720,6 +695,12 @@ pkix_iso_dsa_oid(Config) when is_list(Config) -> %%-------------------------------------------------------------------- %% Internal functions ------------------------------------------------ %%-------------------------------------------------------------------- +asn1_encode_decode({Asn1Type, Der, not_encrypted} = Entry) -> + Decoded = public_key:der_decode(Asn1Type, Der), + Decoded = public_key:pem_entry_decode(Entry), + Entry = public_key:pem_entry_encode(Asn1Type, Decoded), + ok. + check_countryname({rdnSequence,DirName}) -> do_check_countryname(DirName). do_check_countryname([]) -> diff --git a/lib/public_key/test/public_key_SUITE_data/pkcs7_ext.pem b/lib/public_key/test/public_key_SUITE_data/pkcs7_ext.pem new file mode 100644 index 0000000000..d7a1d01fe1 --- /dev/null +++ b/lib/public_key/test/public_key_SUITE_data/pkcs7_ext.pem @@ -0,0 +1,62 @@ +-----BEGIN PKCS7----- +MIILCAYJKoZIhvcNAQcCoIIK+TCCCvUCAQExDjAMBggqhkiG9w0CBQUAMIIFmwYJ +KoZIhvcNAQcBoIIFjASCBYgwggWEBgkqhkiG9w0BBwOgggV1MIIFcQIBADGCAmQw +ggJgAgEAMEgwPDELMAkGA1UEBhMCU0UxETAPBgNVBAoMCEVyaWNzc29uMRowGAYD +VQQDDBFWQ19SQlNfU3ViQ0FfVjNfMQIIcw3ZS5VSTIwwDQYJKoZIhvcNAQEBBQAE +ggIAFW0vd8wY2FJ87KVyUqcdK5uCmnjwC6uPbypDqnL44Fe4iAAiNOvmqt1Crm46 +pg9gOq50NbrRb+PY+UUM7lEUNNKZ61cul2iwGwp6r41l05EbMqgfsNoJkH+bTM8Y +YhME4sT+AzdmPHIg1PGoM+pAMHzpjcdnaHFSlfSmwq5xfZwWelR2TDz7arO+AKCk +DVIEnG9qHBrUWvDoT23VDVQQXP5Uja0Nml7B7Jt2RW2EKAiCAYDujkjIWcGy3F3X +2Q+Nm4K2nJKnkdMI5kS0Eu9uHp24VHn98sEyqn8rDiLFOaj5BskQIVMDN6npssgr +X4ChmBiVcquaxCoHMqQYGa/Jrd66C8WK2lQH3NpDCsULS+m6Z76bvXDFyL0K6rEP +sOcn8J91LfB5jXeSvS3vi7zk07M/IwAL03fVKvqiKU65D4859AOgbjkGyytWG1iv +t7ENh6GYHGJj71L+OlZZH25cJQ/2gGsYs4IYrT6w4Z1X5TscOL/tBiCDdTwcdT0q ++YdkL9ZONouHvgszb9IFvfFErzmmG7jTHwC/TzR0nC8vPog9+y05G4vnD1h7lzH7 +8xDsGrn86gcjYXXRPfc4AxDZfmaM8S0SFmd+O7B24sUKmSyxF3A7OVnb0/rTMuez +Izoy6RW9WQpCJM5R9k7YFDI5lQI+PiKT8GqzQuFIFXRYwOIwggMCBgkqhkiG9w0B +BwEwEQYFKw4DAgcECLsGKZ/iQ1HBgIIC4J1lxb/gn6EosJyMrTV8KnJxvD+Garzp +zmrDNvl9Q7CHmpNLuW3dngU5JcB5dElq7B+j6+RXNkupcrd2dvllAmwfPpFblmNp +Snsn99TTwDYv4LrpxNCcoIKSm93H28wfszhPv75zD9+/aIy4JK4UwYuv+p5JHfLW +EhvWO4pxUc2YpB8jiUVKTJJcRohry/lwvXu5s8VjmpoADSflHtAA4DUhFKX2fafu +Ux7muxbh7xFViNY6laQ/tuZuxxjs2Eb5aWWizO00cyLP2724vFQL+lnvyAvtSmcD +z2hOeOvvch6sJ4krx/gFznqe/lVksPyJQOj+Or8RTbC26kV4GQwiuGqgp6zhNjYe +4niPvGxVAFz8Qdv8Zu47fSHgI2nz5YlWuE2NiQ1qtCbMsf2k/NnZrTgx2oZxnZvL +B2We2D0u6BRZo4XMvGUqOLlGIV5scusv39/sBblJGOwNjtekG/pIRmiHXuI+RQOX +yr4tLR8clylf/HEMmYn2UVxXXuWsEr6zdBB3u3JhXhq+YmDpYYnTkxZq4nTz7oMY +MicrF0+iUrun6lIAXEU6yOSPehje5PfZW5PqKlpugKYIQSsbuJ4t/8n/MczHbRk9 +CcIX05OeWUdxRPKYa7Jt8umXnuIqWu7s7uZpbiB/tmuW4Cp16xUv53SgrTm4tiMq +b7O3ftMmEiFZ+uXds/ODfh7bTe4YlWdyimkCcyI4dcIjLxe+ifx4T+b4LktIc5Pd +5MHwAN+F1yIWnPxi8Nep9Pnw4HiX/ZkL0jHG0msZgZ60jb1U3LV4w3VI1WrsjvJM +6M+l7HM3xeTl9posjVQPxb7kyX5s6gDe4IaatPrNYcsDJ4t43v/se/nvlrQtkJzv +D4S2a9l833kYIC0MvoT8dqJuwySPZxjK0Io69sd6Af1BTGBoSQL75pOntrQUhICl +/kfjBkG5h6tpJFSZQEReK3Kg9rKIax5VwgQUte2yVu3EYARd3YZ7On+gggMTMIID +DzCCAfegAwIBAgITAkxY3LTPyvVkS5SUobGvznBgQDANBgkqhkiG9w0BAQUFADBC +MQswCQYDVQQGEwJTRTERMA8GA1UEChMIRXJpY3Nzb24xIDAeBgNVBAMTF0M4MjYx +MjQ1ODEuZXJpY3Nzb24uY29tMB4XDTEzMDgyMTE1MTcwM1oXDTE0MDgyMTE1MTcw +M1owQjELMAkGA1UEBhMCU0UxETAPBgNVBAoTCEVyaWNzc29uMSAwHgYDVQQDExdD +ODI2MTI0NTgxLmVyaWNzc29uLmNvbTCCASIwDQYJKoZIhvcNAQEBBQADggEPADCC +AQoCggEBAPgg9zlAP6Z8vDMq+Ux0mq1RPLLtG2kByeauGvKdzbRLxtiyyKlknFQ8 +jdn8w3NrQiXTYSEcR0eDWjpLiwvkW2WC+lARIHUWQjRJWQIaSQ1lu9rDHlMYr2xm +6EF6QDgr/9fqkY1IrF/gEAwnNQhT44qCzSr/jqmf5phd5qslzYlpYY97yeEihiCT +wa/BNl1puS3+ayXI9e73Fpeysd0+TFjgbUwhUZn8kcKnDiynb19cyKzk4F1MQHwu +QDFUkxtFcKMW8GikjEYy0Gw8CJUPl4SedtwoU4PGhWqgA/vYOPhdP6LfSBhTmU3s +tUrFxUuMAiRF24JHdTj2bv+huDotWu0CAwEAATANBgkqhkiG9w0BAQUFAAOCAQEA +PtB1eG9FbriUPD79Kb5uyt15JoROPDBc3voR9HffqDsANyEJ3VPlvAFEyrQzbdnA +V5slZRR7M5AJBha1K3BIR7Cs74BlCXiiuWi358HnPGsHqqJjKVxlTKJksrRLvUr4 +K2bG1kBniQU/PkSZjB1DbSwAqw4So9BKLbzQFE8888/yETeCIEWnG2YMiRe1GB0r +P/88QJctNrsT5oLdZ9E4igcAoGna6UR71PJSFCBoJ5WsnofMf44gZr7bgg2szoZr +KDPnrlsi9SM4nWzTaxSTjEp3397QMwEHosJxwXv/Zy5QyGBDYfynaTRUVS2BwIfo +AqRdylyrbv/+3NBQxdERRjGCAigwggIkAgEBMFkwQjELMAkGA1UEBhMCU0UxETAP +BgNVBAoTCEVyaWNzc29uMSAwHgYDVQQDExdDODI2MTI0NTgxLmVyaWNzc29uLmNv +bQITAkxY3LTPyvVkS5SUobGvznBgQDAMBggqhkiG9w0CBQUAoIGiMBIGCmCGSAGG ++EUBCQIxBBMCMTkwGAYJKoZIhvcNAQkDMQsGCSqGSIb3DQEHATAfBgkqhkiG9w0B +CQQxEgQQaEUDvpv6H163UM7zAQiMvDAgBgpghkgBhvhFAQkFMRIEEN4FI8tal3of +ZTXKi1Ny2cswLwYKYIZIAYb4RQEJBzEhEx8yOUFBQjJFNTY5OUY1QjI1QTJEQUI3 +NDlGN0Q0QTFBMA0GCSqGSIb3DQEBAQUABIIBACnR54LqeHZ0u8bSErSnGupEytHK +xbfShraXl3DFPnIZYs0HUuuriw5/BhkFHBsSXO8Oqm759/UgxOjnCUD2AKHenGoK +LB0yqLGe/USBs0IkBv6lXg7HJhSDNqAPES6a5iUVIRv+M40Ldob570MKjZhERVPN +AVSHMJHKmtVTZGt/VqiVk0qqZeV9nqhaSPFyW9pQU0PKep0lFltnwCHUTZiiqHuk +SIpZFCmIgahAUcl/WrxiW4xC9L5+wBgsuaUU5LqLZwg3AFua0aaDs6NZXpSE0A43 +zm5whhmkVePjnSUUr78AoBRalsBdMkDwLoUZZ1Hhq+/WH+WW7TQ96zm+uzE= +-----END PKCS7----- + diff --git a/lib/ssl/src/ssl_cipher.erl b/lib/ssl/src/ssl_cipher.erl index ec5d793d65..09aad8e414 100644 --- a/lib/ssl/src/ssl_cipher.erl +++ b/lib/ssl/src/ssl_cipher.erl @@ -36,7 +36,7 @@ decipher/5, cipher/5, suite/1, suites/1, anonymous_suites/0, psk_suites/1, srp_suites/0, openssl_suite/1, openssl_suite_name/1, filter/2, filter_suites/1, - hash_algorithm/1, sign_algorithm/1]). + hash_algorithm/1, sign_algorithm/1, is_acceptable_hash/2]). -compile(inline). @@ -1009,6 +1009,7 @@ filter(DerCert, Ciphers) -> filter_keyuse(OtpCert, (Ciphers -- rsa_keyed_suites()) -- dsa_signed_suites(), [], ecdhe_ecdsa_suites()) end, + case public_key:pkix_sign_types(SigAlg#'SignatureAlgorithm'.algorithm) of {_, rsa} -> Ciphers1 -- ecdsa_signed_suites(); @@ -1191,15 +1192,15 @@ hash_size(md5) -> hash_size(sha) -> 20; %% Uncomment when adding cipher suite that needs it -%% hash_size(sha224) -> -%% 28; +hash_size(sha224) -> + 28; hash_size(sha256) -> 32; hash_size(sha384) -> - 48. + 48; %% Uncomment when adding cipher suite that needs it -%% hash_size(sha512) -> -%% 64. +hash_size(sha512) -> + 64. %% RFC 5246: 6.2.3.2. CBC Block Cipher %% @@ -1259,15 +1260,15 @@ generic_stream_cipher_from_bin(T, HashSz) -> %% SSL 3.0 and TLS 1.0 as it is not strictly required and breaks %% interopability with for instance Google. is_correct_padding(#generic_block_cipher{padding_length = Len, - padding = Padding}, {3, N}) + padding = Padding}, {3, N}) when N == 0; N == 1 -> Len == byte_size(Padding); %% Padding must be check in TLS 1.1 and after is_correct_padding(#generic_block_cipher{padding_length = Len, - padding = Padding}, _) -> + padding = Padding}, _) -> Len == byte_size(Padding) andalso list_to_binary(lists:duplicate(Len, Len)) == Padding. - + get_padding(Length, BlockSize) -> get_padding_aux(BlockSize, Length rem BlockSize). @@ -1291,7 +1292,7 @@ next_iv(Bin, IV) -> rsa_signed_suites() -> dhe_rsa_suites() ++ rsa_suites() ++ psk_rsa_suites() ++ srp_rsa_suites() ++ - ecdh_rsa_suites(). + ecdh_rsa_suites() ++ ecdhe_rsa_suites(). rsa_keyed_suites() -> dhe_rsa_suites() ++ rsa_suites() ++ diff --git a/lib/ssl/src/tls_connection.erl b/lib/ssl/src/tls_connection.erl index 77f49c5d2a..0415ea6ecc 100644 --- a/lib/ssl/src/tls_connection.erl +++ b/lib/ssl/src/tls_connection.erl @@ -76,7 +76,8 @@ negotiated_version, % tls_version() client_certificate_requested = false, key_algorithm, % atom as defined by cipher_suite - hashsign_algorithm, % atom as defined by cipher_suite + hashsign_algorithm = {undefined, undefined}, + cert_hashsign_algorithm, public_key_info, % PKIX: {Algorithm, PublicKey, PublicKeyParams} private_key, % PKIX: #'RSAPrivateKey'{} diffie_hellman_params, % PKIX: #'DHParameter'{} relevant for server side @@ -366,6 +367,7 @@ hello(#hello_request{}, #state{role = client} = State0) -> next_state(hello, hello, Record, State); hello(#server_hello{cipher_suite = CipherSuite, + hash_signs = HashSign, compression_method = Compression} = Hello, #state{session = #session{session_id = OldId}, connection_states = ConnectionStates0, @@ -388,9 +390,10 @@ hello(#server_hello{cipher_suite = CipherSuite, _ -> NextProtocol end, - + State = State0#state{key_algorithm = KeyAlgorithm, - hashsign_algorithm = default_hashsign(Version, KeyAlgorithm), + hashsign_algorithm = + negotiated_hashsign(HashSign, KeyAlgorithm, Version), negotiated_version = Version, connection_states = ConnectionStates, premaster_secret = PremasterSecret, @@ -406,22 +409,28 @@ hello(#server_hello{cipher_suite = CipherSuite, end end; -hello(Hello = #client_hello{client_version = ClientVersion}, +hello(Hello = #client_hello{client_version = ClientVersion, + hash_signs = HashSigns}, State = #state{connection_states = ConnectionStates0, port = Port, session = #session{own_certificate = Cert} = Session0, renegotiation = {Renegotiation, _}, session_cache = Cache, session_cache_cb = CacheCb, ssl_options = SslOpts}) -> + + HashSign = tls_handshake:select_hashsign(HashSigns, Cert), case tls_handshake:hello(Hello, SslOpts, {Port, Session0, Cache, CacheCb, ConnectionStates0, Cert}, Renegotiation) of - {Version, {Type, Session}, ConnectionStates, ProtocolsToAdvertise, + {Version, {Type, #session{cipher_suite = CipherSuite} = Session}, ConnectionStates, ProtocolsToAdvertise, EcPointFormats, EllipticCurves} -> + {KeyAlgorithm, _, _, _} = ssl_cipher:suite_definition(CipherSuite), + NH = negotiated_hashsign(HashSign, KeyAlgorithm, Version), do_server_hello(Type, ProtocolsToAdvertise, EcPointFormats, EllipticCurves, State#state{connection_states = ConnectionStates, negotiated_version = Version, session = Session, + hashsign_algorithm = NH, client_ecc = {EllipticCurves, EcPointFormats}}); #alert{} = Alert -> handle_own_alert(Alert, ClientVersion, hello, State) @@ -526,7 +535,7 @@ certify(#certificate{} = Cert, Opts#ssl_options.verify, Opts#ssl_options.verify_fun, Role) of {PeerCert, PublicKeyInfo} -> - handle_peer_cert(PeerCert, PublicKeyInfo, + handle_peer_cert(Role, PeerCert, PublicKeyInfo, State#state{client_certificate_requested = false}); #alert{} = Alert -> handle_own_alert(Alert, Version, certify, State) @@ -552,9 +561,11 @@ certify(#server_key_exchange{} = Msg, #state{role = client, key_algorithm = rsa} = State) -> handle_unexpected_message(Msg, certify_server_keyexchange, State); -certify(#certificate_request{}, State0) -> +certify(#certificate_request{hashsign_algorithms = HashSigns}, + #state{session = #session{own_certificate = Cert}} = State0) -> + HashSign = tls_handshake:select_hashsign(HashSigns, Cert), {Record, State} = next_record(State0#state{client_certificate_requested = true}), - next_state(certify, certify, Record, State); + next_state(certify, certify, Record, State#state{cert_hashsign_algorithm = HashSign}); %% PSK and RSA_PSK might bypass the Server-Key-Exchange certify(#server_hello_done{}, @@ -757,21 +768,18 @@ cipher(#hello_request{}, State0) -> cipher(#certificate_verify{signature = Signature, hashsign_algorithm = CertHashSign}, #state{role = server, - public_key_info = PublicKeyInfo, + public_key_info = {Algo, _, _} =PublicKeyInfo, negotiated_version = Version, session = #session{master_secret = MasterSecret}, - hashsign_algorithm = ConnectionHashSign, tls_handshake_history = Handshake } = State0) -> - HashSign = case CertHashSign of - {_, _} -> CertHashSign; - _ -> ConnectionHashSign - end, + + HashSign = tls_handshake:select_cert_hashsign(CertHashSign, Algo, Version), case tls_handshake:certificate_verify(Signature, PublicKeyInfo, Version, HashSign, MasterSecret, Handshake) of valid -> {Record, State} = next_record(State0), - next_state(cipher, cipher, Record, State); + next_state(cipher, cipher, Record, State#state{cert_hashsign_algorithm = HashSign}); #alert{} = Alert -> handle_own_alert(Alert, Version, cipher, State0) end; @@ -1369,25 +1377,34 @@ sync_send_all_state_event(FsmPid, Event) -> {error, closed} end. -%% We do currently not support cipher suites that use fixed DH. -%% If we want to implement that we should add a code -%% here to extract DH parameters form cert. -handle_peer_cert(PeerCert, PublicKeyInfo, - #state{session = Session} = State0) -> +handle_peer_cert(Role, PeerCert, PublicKeyInfo, + #state{session = #session{cipher_suite = CipherSuite} = Session} = State0) -> State1 = State0#state{session = Session#session{peer_certificate = PeerCert}, public_key_info = PublicKeyInfo}, - State2 = case PublicKeyInfo of - {?'id-ecPublicKey', #'ECPoint'{point = _ECPoint} = PublicKey, PublicKeyParams} -> - ECDHKey = public_key:generate_key(PublicKeyParams), - State3 = State1#state{diffie_hellman_keys = ECDHKey}, - ec_dh_master_secret(ECDHKey, PublicKey, State3); - - _ -> State1 - end, + {KeyAlg,_,_,_} = ssl_cipher:suite_definition(CipherSuite), + State2 = handle_peer_cert_key(Role, PeerCert, PublicKeyInfo, KeyAlg, State1), + {Record, State} = next_record(State2), next_state(certify, certify, Record, State). +handle_peer_cert_key(client, _, + {?'id-ecPublicKey', #'ECPoint'{point = _ECPoint} = PublicKey, PublicKeyParams}, + KeyAlg, State) when KeyAlg == ecdh_rsa; + KeyAlg == ecdh_ecdsa -> + ECDHKey = public_key:generate_key(PublicKeyParams), + ec_dh_master_secret(ECDHKey, PublicKey, State#state{diffie_hellman_keys = ECDHKey}); + +%% We do currently not support cipher suites that use fixed DH. +%% If we want to implement that the following clause can be used +%% to extract DH parameters form cert. +%% handle_peer_cert_key(client, _PeerCert, {?dhpublicnumber, PublicKey, PublicKeyParams}, {_,SignAlg}, +%% #state{diffie_hellman_keys = {_, MyPrivatKey}} = State) when SignAlg == dh_rsa; +%% SignAlg == dh_dss -> +%% dh_master_secret(PublicKeyParams, PublicKey, MyPrivatKey, State); +handle_peer_cert_key(_, _, _, _, State) -> + State. + certify_client(#state{client_certificate_requested = true, role = client, connection_states = ConnectionStates0, transport_cb = Transport, @@ -1414,10 +1431,9 @@ verify_client_cert(#state{client_certificate_requested = true, role = client, private_key = PrivateKey, session = #session{master_secret = MasterSecret, own_certificate = OwnCert}, - hashsign_algorithm = HashSign, + cert_hashsign_algorithm = HashSign, tls_handshake_history = Handshake0} = State) -> - %%TODO: for TLS 1.2 we can choose a different/stronger HashSign combination for this. case tls_handshake:client_certificate_verify(OwnCert, MasterSecret, Version, HashSign, PrivateKey, Handshake0) of #certificate_verify{} = Verified -> @@ -1560,8 +1576,7 @@ server_hello(ServerHello, #state{transport_cb = Transport, Transport:send(Socket, BinMsg), State#state{connection_states = ConnectionStates1, tls_handshake_history = Handshake1, - key_algorithm = KeyAlgorithm, - hashsign_algorithm = default_hashsign(Version, KeyAlgorithm)}. + key_algorithm = KeyAlgorithm}. server_hello_done(#state{transport_cb = Transport, socket = Socket, @@ -1937,7 +1952,7 @@ request_client_cert(#state{ssl_options = #ssl_options{verify = verify_peer}, negotiated_version = Version, socket = Socket, transport_cb = Transport} = State) -> - Msg = tls_handshake:certificate_request(ConnectionStates0, CertDbHandle, CertDbRef), + Msg = tls_handshake:certificate_request(ConnectionStates0, CertDbHandle, CertDbRef, Version), {BinMsg, ConnectionStates, Handshake} = encode_handshake(Msg, Version, ConnectionStates0, Handshake0), Transport:send(Socket, BinMsg), @@ -2014,12 +2029,13 @@ handle_server_key(#server_key_exchange{exchange_keys = Keys}, #state{key_algorithm = KeyAlg, negotiated_version = Version} = State) -> Params = tls_handshake:decode_server_key(Keys, KeyAlg, Version), - HashSign = connection_hashsign(Params#server_key_params.hashsign, State), - case HashSign of - {_, SignAlgo} when SignAlgo == anon; SignAlgo == ecdh_anon -> - server_master_secret(Params#server_key_params.params, State); - _ -> - verify_server_key(Params, HashSign, State) + HashSign = negotiated_hashsign(Params#server_key_params.hashsign, KeyAlg, Version), + case is_anonymous(KeyAlg) of + true -> + server_master_secret(Params#server_key_params.params, + State#state{hashsign_algorithm = HashSign}); + false -> + verify_server_key(Params, HashSign, State#state{hashsign_algorithm = HashSign}) end. verify_server_key(#server_key_params{params = Params, @@ -2995,11 +3011,6 @@ get_pending_connection_state_prf(CStates, Direction) -> CS = tls_record:pending_connection_state(CStates, Direction), CS#connection_state.security_parameters#security_parameters.prf_algorithm. -connection_hashsign(HashSign = {_, _}, _State) -> - HashSign; -connection_hashsign(_, #state{hashsign_algorithm = HashSign}) -> - HashSign. - %% RFC 5246, Sect. 7.4.1.4.1. Signature Algorithms %% If the client does not send the signature_algorithms extension, the %% server MUST do the following: @@ -3014,12 +3025,18 @@ connection_hashsign(_, #state{hashsign_algorithm = HashSign}) -> %% - If the negotiated key exchange algorithm is one of (ECDH_ECDSA, %% ECDHE_ECDSA), behave as if the client had sent value {sha1,ecdsa}. +negotiated_hashsign(undefined, Algo, Version) -> + default_hashsign(Version, Algo); +negotiated_hashsign(HashSign = {_, _}, _, _) -> + HashSign. + default_hashsign(_Version = {Major, Minor}, KeyExchange) - when Major == 3 andalso Minor >= 3 andalso + when Major >= 3 andalso Minor >= 3 andalso (KeyExchange == rsa orelse KeyExchange == dhe_rsa orelse KeyExchange == dh_rsa orelse KeyExchange == ecdhe_rsa orelse + KeyExchange == ecdh_rsa orelse KeyExchange == srp_rsa) -> {sha, rsa}; default_hashsign(_Version, KeyExchange) @@ -3027,12 +3044,12 @@ default_hashsign(_Version, KeyExchange) KeyExchange == dhe_rsa; KeyExchange == dh_rsa; KeyExchange == ecdhe_rsa; + KeyExchange == ecdh_rsa; KeyExchange == srp_rsa -> {md5sha, rsa}; default_hashsign(_Version, KeyExchange) when KeyExchange == ecdhe_ecdsa; - KeyExchange == ecdh_ecdsa; - KeyExchange == ecdh_rsa -> + KeyExchange == ecdh_ecdsa -> {sha, ecdsa}; default_hashsign(_Version, KeyExchange) when KeyExchange == dhe_dss; @@ -3081,3 +3098,13 @@ select_curve(#state{client_ecc = {[Curve|_], _}}) -> {namedCurve, Curve}; select_curve(_) -> {namedCurve, ?secp256k1}. + +is_anonymous(Algo) when Algo == dh_anon; + Algo == ecdh_anon; + Algo == psk; + Algo == dhe_psk; + Algo == rsa_psk; + Algo == srp_anon -> + true; +is_anonymous(_) -> + false. diff --git a/lib/ssl/src/tls_handshake.erl b/lib/ssl/src/tls_handshake.erl index 51fd2e1dc9..6cc6e9e885 100644 --- a/lib/ssl/src/tls_handshake.erl +++ b/lib/ssl/src/tls_handshake.erl @@ -34,11 +34,12 @@ -export([master_secret/4, client_hello/8, server_hello/7, hello/4, hello_request/0, certify/7, certificate/4, client_certificate_verify/6, certificate_verify/6, verify_signature/5, - certificate_request/3, key_exchange/3, server_key_exchange_hash/2, + certificate_request/4, key_exchange/3, server_key_exchange_hash/2, finished/5, verify_connection/6, get_tls_handshake/3, decode_client_key/3, decode_server_key/3, server_hello_done/0, encode_handshake/2, init_handshake_history/0, update_handshake_history/2, - decrypt_premaster_secret/2, prf/5, next_protocol/1]). + decrypt_premaster_secret/2, prf/5, next_protocol/1, select_hashsign/2, + select_cert_hashsign/3]). -export([dec_hello_extensions/2]). @@ -82,7 +83,7 @@ client_hello(Host, Port, ConnectionStates, renegotiation_info = renegotiation_info(client, ConnectionStates, Renegotiation), srp = SRP, - hash_signs = default_hash_signs(), + hash_signs = advertised_hash_signs(Version), ec_point_formats = EcPointFormats, elliptic_curves = EllipticCurves, next_protocol_negotiation = @@ -152,7 +153,6 @@ hello(#server_hello{cipher_suite = CipherSuite, server_version = Version, #ssl_options{secure_renegotiate = SecureRenegotation, next_protocol_selector = NextProtocolSelector, versions = SupportedVersions}, ConnectionStates0, Renegotiation) -> - %%TODO: select hash and signature algorigthm case tls_record:is_acceptable_version(Version, SupportedVersions) of true -> case handle_renegotiation_info(client, Info, ConnectionStates0, @@ -177,7 +177,6 @@ hello(#server_hello{cipher_suite = CipherSuite, server_version = Version, hello(#client_hello{client_version = ClientVersion} = Hello, #ssl_options{versions = Versions} = SslOpts, {Port, Session0, Cache, CacheCb, ConnectionStates0, Cert}, Renegotiation) -> - %% TODO: select hash and signature algorithm Version = select_version(ClientVersion, Versions), case tls_record:is_acceptable_version(Version, Versions) of true -> @@ -298,7 +297,7 @@ client_certificate_verify(undefined, _, _, _, _, _) -> client_certificate_verify(_, _, _, _, undefined, _) -> ignore; client_certificate_verify(OwnCert, MasterSecret, Version, - {HashAlgo, SignAlgo}, + {HashAlgo, _} = HashSign, PrivateKey, {Handshake, _}) -> case public_key:pkix_is_fixed_dh_cert(OwnCert) of true -> @@ -307,7 +306,7 @@ client_certificate_verify(OwnCert, MasterSecret, Version, Hashes = calc_certificate_verify(Version, HashAlgo, MasterSecret, Handshake), Signed = digitally_signed(Version, Hashes, HashAlgo, PrivateKey), - #certificate_verify{signature = Signed, hashsign_algorithm = {HashAlgo, SignAlgo}} + #certificate_verify{signature = Signed, hashsign_algorithm = HashSign} end. %%-------------------------------------------------------------------- @@ -349,17 +348,17 @@ verify_signature(_Version, Hash, {HashAlgo, ecdsa}, Signature, {?'id-ecPublicKey public_key:verify({digest, Hash}, HashAlgo, Signature, {PublicKey, PublicKeyParams}). %%-------------------------------------------------------------------- --spec certificate_request(#connection_states{}, db_handle(), certdb_ref()) -> +-spec certificate_request(#connection_states{}, db_handle(), certdb_ref(), tls_version()) -> #certificate_request{}. %% %% Description: Creates a certificate_request message, called by the server. %%-------------------------------------------------------------------- -certificate_request(ConnectionStates, CertDbHandle, CertDbRef) -> +certificate_request(ConnectionStates, CertDbHandle, CertDbRef, Version) -> #connection_state{security_parameters = #security_parameters{cipher_suite = CipherSuite}} = tls_record:pending_connection_state(ConnectionStates, read), Types = certificate_types(CipherSuite), - HashSigns = default_hash_signs(), + HashSigns = advertised_hash_signs(Version), Authorities = certificate_authorities(CertDbHandle, CertDbRef), #certificate_request{ certificate_types = Types, @@ -687,6 +686,54 @@ prf({3,1}, Secret, Label, Seed, WantedLength) -> prf({3,_N}, Secret, Label, Seed, WantedLength) -> {ok, ssl_tls1:prf(?SHA256, Secret, Label, Seed, WantedLength)}. + +%%-------------------------------------------------------------------- +-spec select_hashsign(#hash_sign_algos{}| undefined, undefined | term()) -> + [{atom(), atom()}] | undefined. + +%% +%% Description: +%%-------------------------------------------------------------------- +select_hashsign(_, undefined) -> + {null, anon}; +select_hashsign(undefined, Cert) -> + #'OTPCertificate'{tbsCertificate = TBSCert} = public_key:pkix_decode_cert(Cert, otp), + #'OTPSubjectPublicKeyInfo'{algorithm = {_,Algo, _}} = TBSCert#'OTPTBSCertificate'.subjectPublicKeyInfo, + select_cert_hashsign(undefined, Algo, {undefined, undefined}); +select_hashsign(#hash_sign_algos{hash_sign_algos = HashSigns}, Cert) -> + #'OTPCertificate'{tbsCertificate = TBSCert} =public_key:pkix_decode_cert(Cert, otp), + #'OTPSubjectPublicKeyInfo'{algorithm = {_,Algo, _}} = TBSCert#'OTPTBSCertificate'.subjectPublicKeyInfo, + DefaultHashSign = {_, Sign} = select_cert_hashsign(undefined, Algo, {undefined, undefined}), + case lists:filter(fun({sha, dsa}) -> + true; + ({_, dsa}) -> + false; + ({Hash, S}) when S == Sign -> + ssl_cipher:is_acceptable_hash(Hash, proplists:get_value(hashs, crypto:supports())); + (_) -> + false + end, HashSigns) of + [] -> + DefaultHashSign; + [HashSign| _] -> + HashSign + end. +%%-------------------------------------------------------------------- +-spec select_cert_hashsign(#hash_sign_algos{}| undefined, oid(), tls_version()) -> + [{atom(), atom()}]. + +%% +%% Description: +%%-------------------------------------------------------------------- +select_cert_hashsign(HashSign, _, {Major, Minor}) when HashSign =/= undefined andalso Major >= 3 andalso Minor >= 3 -> + HashSign; +select_cert_hashsign(undefined,?'id-ecPublicKey', _) -> + {sha, ecdsa}; +select_cert_hashsign(undefined, ?rsaEncryption, _) -> + {md5sha, rsa}; +select_cert_hashsign(undefined, ?'id-dsa', _) -> + {sha, dsa}. + %%-------------------------------------------------------------------- %%% Internal functions %%-------------------------------------------------------------------- @@ -1066,7 +1113,7 @@ dec_hs(_Version, ?CLIENT_HELLO, <<?BYTE(Major), ?BYTE(Minor), Random:32/binary, cipher_suites = from_2bytes(CipherSuites), compression_methods = Comp_methods, renegotiation_info = RenegotiationInfo, - srp = SRP, + srp = SRP, hash_signs = HashSigns, elliptic_curves = EllipticCurves, next_protocol_negotiation = NextProtocolNegotiation @@ -1179,12 +1226,12 @@ dec_ske_params(Len, Keys, Version) -> dec_ske_signature(Params, <<?BYTE(HashAlgo), ?BYTE(SignAlgo), ?UINT16(0)>>, {Major, Minor}) - when Major == 3, Minor >= 3 -> + when Major >= 3, Minor >= 3 -> HashSign = {ssl_cipher:hash_algorithm(HashAlgo), ssl_cipher:sign_algorithm(SignAlgo)}, {Params, HashSign, <<>>}; dec_ske_signature(Params, <<?BYTE(HashAlgo), ?BYTE(SignAlgo), ?UINT16(Len), Signature:Len/binary>>, {Major, Minor}) - when Major == 3, Minor >= 3 -> + when Major >= 3, Minor >= 3 -> HashSign = {ssl_cipher:hash_algorithm(HashAlgo), ssl_cipher:sign_algorithm(SignAlgo)}, {Params, HashSign, Signature}; dec_ske_signature(Params, <<>>, _) -> @@ -1219,11 +1266,11 @@ dec_server_key(<<?BYTE(?NAMED_CURVE), ?UINT16(CurveID), params_bin = BinMsg, hashsign = HashSign, signature = Signature}; -dec_server_key(<<?UINT16(Len), PskIdentityHint:Len/binary>> = KeyStruct, +dec_server_key(<<?UINT16(Len), PskIdentityHint:Len/binary, _/binary>> = KeyStruct, KeyExchange, Version) when KeyExchange == ?KEY_EXCHANGE_PSK; KeyExchange == ?KEY_EXCHANGE_RSA_PSK -> Params = #server_psk_params{ - hint = PskIdentityHint}, + hint = PskIdentityHint}, {BinMsg, HashSign, Signature} = dec_ske_params(Len + 2, KeyStruct, Version), #server_key_params{params = Params, params_bin = BinMsg, @@ -1236,8 +1283,8 @@ dec_server_key(<<?UINT16(Len), IdentityHint:Len/binary, ?KEY_EXCHANGE_DHE_PSK, Version) -> DHParams = #server_dh_params{dh_p = P, dh_g = G, dh_y = Y}, Params = #server_dhe_psk_params{ - hint = IdentityHint, - dh_params = DHParams}, + hint = IdentityHint, + dh_params = DHParams}, {BinMsg, HashSign, Signature} = dec_ske_params(Len + PLen + GLen + YLen + 8, KeyStruct, Version), #server_key_params{params = Params, params_bin = BinMsg, @@ -1297,16 +1344,14 @@ dec_hello_extensions(<<?UINT16(?SIGNATURE_ALGORITHMS_EXT), ?UINT16(Len), dec_hello_extensions(<<?UINT16(?ELLIPTIC_CURVES_EXT), ?UINT16(Len), ExtData:Len/binary, Rest/binary>>, Acc) -> - EllipticCurveListLen = Len - 2, - <<?UINT16(EllipticCurveListLen), EllipticCurveList/binary>> = ExtData, + <<?UINT16(_), EllipticCurveList/binary>> = ExtData, EllipticCurves = [ssl_tls1:enum_to_oid(X) || <<X:16>> <= EllipticCurveList], dec_hello_extensions(Rest, [{elliptic_curves, #elliptic_curves{elliptic_curve_list = EllipticCurves}} | Acc]); dec_hello_extensions(<<?UINT16(?EC_POINT_FORMATS_EXT), ?UINT16(Len), ExtData:Len/binary, Rest/binary>>, Acc) -> - ECPointFormatListLen = Len - 1, - <<?BYTE(ECPointFormatListLen), ECPointFormatList/binary>> = ExtData, + <<?BYTE(_), ECPointFormatList/binary>> = ExtData, ECPointFormats = binary_to_list(ECPointFormatList), dec_hello_extensions(Rest, [{ec_point_formats, #ec_point_formats{ec_point_format_list = ECPointFormats}} | Acc]); @@ -1755,26 +1800,6 @@ apply_user_fun(Fun, OtpCert, ExtensionOrError, UserState0, SslState) -> {unknown, {SslState, UserState}} end. --define(TLSEXT_SIGALG_RSA(MD), {MD, rsa}). --define(TLSEXT_SIGALG_DSA(MD), {MD, dsa}). --define(TLSEXT_SIGALG_ECDSA(MD), {MD, ecdsa}). - --define(TLSEXT_SIGALG(MD), ?TLSEXT_SIGALG_ECDSA(MD), ?TLSEXT_SIGALG_RSA(MD)). - -default_hash_signs() -> - HashSigns = [?TLSEXT_SIGALG(sha512), - ?TLSEXT_SIGALG(sha384), - ?TLSEXT_SIGALG(sha256), - ?TLSEXT_SIGALG(sha224), - ?TLSEXT_SIGALG(sha), - ?TLSEXT_SIGALG_DSA(sha), - ?TLSEXT_SIGALG_RSA(md5)], - CryptoSupport = proplists:get_value(public_keys, crypto:supports()), - HasECC = proplists:get_bool(ecdsa, CryptoSupport), - #hash_sign_algos{hash_sign_algos = - lists:filter(fun({_, ecdsa}) -> HasECC; - (_) -> true end, HashSigns)}. - handle_hello_extensions(#client_hello{random = Random, cipher_suites = CipherSuites, renegotiation_info = Info, @@ -1825,3 +1850,26 @@ handle_srp_extension(#srp{username = Username}, Session) -> int_to_bin(I) -> L = (length(integer_to_list(I, 16)) + 1) div 2, <<I:(L*8)>>. + +-define(TLSEXT_SIGALG_RSA(MD), {MD, rsa}). +-define(TLSEXT_SIGALG_DSA(MD), {MD, dsa}). +-define(TLSEXT_SIGALG_ECDSA(MD), {MD, ecdsa}). + +-define(TLSEXT_SIGALG(MD), ?TLSEXT_SIGALG_ECDSA(MD), ?TLSEXT_SIGALG_RSA(MD)). + +advertised_hash_signs({Major, Minor}) when Major >= 3 andalso Minor >= 3 -> + HashSigns = [?TLSEXT_SIGALG(sha512), + ?TLSEXT_SIGALG(sha384), + ?TLSEXT_SIGALG(sha256), + ?TLSEXT_SIGALG(sha224), + ?TLSEXT_SIGALG(sha), + ?TLSEXT_SIGALG_DSA(sha), + ?TLSEXT_SIGALG_RSA(md5)], + CryptoSupport = crypto:supports(), + HasECC = proplists:get_bool(ecdsa, proplists:get_value(public_keys, CryptoSupport)), + Hashs = proplists:get_value(hashs, CryptoSupport), + #hash_sign_algos{hash_sign_algos = + lists:filter(fun({Hash, ecdsa}) -> HasECC andalso proplists:get_bool(Hash, Hashs); + ({Hash, _}) -> proplists:get_bool(Hash, Hashs) end, HashSigns)}; +advertised_hash_signs(_) -> + undefined. diff --git a/lib/ssl/test/Makefile b/lib/ssl/test/Makefile index 39aa22ffb4..cb919baf4e 100644 --- a/lib/ssl/test/Makefile +++ b/lib/ssl/test/Makefile @@ -47,6 +47,7 @@ MODULES = \ ssl_payload_SUITE \ ssl_session_cache_SUITE \ ssl_to_openssl_SUITE \ + ssl_ECC_SUITE \ make_certs\ erl_make_certs diff --git a/lib/ssl/test/ssl_ECC_SUITE.erl b/lib/ssl/test/ssl_ECC_SUITE.erl new file mode 100644 index 0000000000..608f2f11c3 --- /dev/null +++ b/lib/ssl/test/ssl_ECC_SUITE.erl @@ -0,0 +1,225 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2007-2013. 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 +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/.2 +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% + +%% + +-module(ssl_ECC_SUITE). + +%% Note: This directive should only be used in test suites. +-compile(export_all). + +-include_lib("common_test/include/ct.hrl"). +-include_lib("public_key/include/public_key.hrl"). + +%%-------------------------------------------------------------------- +%% Common Test interface functions ----------------------------------- +%%-------------------------------------------------------------------- + +suite() -> [{ct_hooks,[ts_install_cth]}]. + +all() -> + [ + {group, 'tlsv1.2'}, + {group, 'tlsv1.1'}, + {group, 'tlsv1'} + ]. + +groups() -> + [ + {'tlsv1.2', [], all_versions_groups()}, + {'tlsv1.1', [], all_versions_groups()}, + {'tlsv1', [], all_versions_groups()}, + {'erlang_server', [], key_cert_combinations()}, + {'erlang_client', [], key_cert_combinations()}, + {'erlang', [], key_cert_combinations()} + ]. + +all_versions_groups ()-> + [{group, 'erlang_server'}, + {group, 'erlang_client'}, + {group, 'erlang'} + ]. + +key_cert_combinations() -> + [client_ec_server_ec, + client_rsa_server_ec, + client_ec_server_rsa, + client_rsa_server_rsa]. + +%%-------------------------------------------------------------------- +init_per_suite(Config) -> + catch crypto:stop(), + try crypto:start() of + ok -> + ssl:start(), + Config + catch _:_ -> + {skip, "Crypto did not start"} + end. + +end_per_suite(_Config) -> + ssl:stop(), + application:stop(crypto). + +%%-------------------------------------------------------------------- +init_per_group(erlang_client, Config) -> + case ssl_test_lib:is_sane_ecc(openssl) of + true -> + common_init_per_group(erlang_client, [{server_type, openssl}, + {client_type, erlang} | Config]); + false -> + {skip, "Known ECC bug in openssl"} + end; + +init_per_group(erlang_server, Config) -> + case ssl_test_lib:is_sane_ecc(openssl) of + true -> + common_init_per_group(erlang_client, [{server_type, erlang}, + {client_type, openssl} | Config]); + false -> + {skip, "Known ECC bug in openssl"} + end; + +init_per_group(erlang = Group, Config) -> + case ssl_test_lib:sufficient_crypto_support(Group) of + true -> + common_init_per_group(erlang, [{server_type, erlang}, + {client_type, erlang} | Config]); + false -> + {skip, "Crypto does not support ECC"} + end; +init_per_group(Group, Config) -> + common_init_per_group(Group, Config). + +common_init_per_group(GroupName, Config) -> + case ssl_test_lib:is_tls_version(GroupName) of + true -> + ssl_test_lib:init_tls_version(GroupName), + [{tls_version, GroupName} | Config]; + _ -> + openssl_check(GroupName, Config) + end. + +end_per_group(_GroupName, Config) -> + Config. + +%%-------------------------------------------------------------------- + +init_per_testcase(_TestCase, Config) -> + ct:log("TLS/SSL version ~p~n ", [tls_record:supported_protocol_versions()]), + ct:log("Ciphers: ~p~n ", [ ssl:cipher_suites()]), + Config. + +end_per_testcase(_TestCase, Config) -> + Config. + +%%-------------------------------------------------------------------- +%% Test Cases -------------------------------------------------------- +%%-------------------------------------------------------------------- + +client_ec_server_ec(Config) when is_list(Config) -> + basic_test("ec1.crt", "ec1.key", "ec2.crt", "ec2.key", Config). + +client_ec_server_rsa(Config) when is_list(Config) -> + basic_test("ec1.crt", "ec1.key", "rsa1.crt", "rsa1.key", Config). + +client_rsa_server_ec(Config) when is_list(Config) -> + basic_test("rsa1.crt", "rsa1.key", "ec2.crt", "ec2.key", Config). + +client_rsa_server_rsa(Config) when is_list(Config) -> + basic_test("rsa1.crt", "rsa1.key", "rsa2.crt", "rsa2.key", Config). + +%%-------------------------------------------------------------------- +%% Internal functions ------------------------------------------------ +%%-------------------------------------------------------------------- +basic_test(ClientCert, ClientKey, ServerCert, ServerKey, Config) -> + DataDir = ?config(data_dir, Config), + SType = ?config(server_type, Config), + CType = ?config(client_type, Config), + {Server, Port} = start_server(SType, + filename:join(DataDir, "CA.pem"), + filename:join(DataDir, ServerCert), + filename:join(DataDir, ServerKey), + Config), + Client = start_client(CType, Port, filename:join(DataDir, "CA.pem"), + filename:join(DataDir, ClientCert), + filename:join(DataDir, ClientKey), Config), + check_result(Server, SType, Client, CType). + +start_client(openssl, Port, CA, Cert, Key, _) -> + Version = tls_record:protocol_version(tls_record:highest_protocol_version([])), + Cmd = "openssl s_client -port " ++ integer_to_list(Port) ++ ssl_test_lib:version_flag(Version) ++ + " -cert " ++ Cert ++ " -CAfile " ++ CA + ++ " -key " ++ Key ++ " -host localhost -msg", + OpenSslPort = open_port({spawn, Cmd}, [stderr_to_stdout]), + true = port_command(OpenSslPort, "Hello world"), + OpenSslPort; +start_client(erlang, Port, CA, Cert, Key, Config) -> + {ClientNode, _, Hostname} = ssl_test_lib:run_where(Config), + ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, + {host, Hostname}, + {from, self()}, + {mfa, {ssl_test_lib, send_recv_result_active, []}}, + {options, [{verify, verify_peer}, {cacertfile, CA}, + {certfile, Cert}, {keyfile, Key}]}]). + +start_server(openssl, CA, Cert, Key, _) -> + Port = ssl_test_lib:inet_port(node()), + Version = tls_record:protocol_version(tls_record:highest_protocol_version([])), + Cmd = "openssl s_server -accept " ++ integer_to_list(Port) ++ ssl_test_lib:version_flag(Version) ++ + " -cert " ++ Cert ++ " -CAfile " ++ CA + ++ " -key " ++ Key ++ " -Verify 2 -msg", + OpenSslPort = open_port({spawn, Cmd}, [stderr_to_stdout]), + ssl_test_lib:wait_for_openssl_server(), + true = port_command(OpenSslPort, "Hello world"), + {OpenSslPort, Port}; + +start_server(erlang, CA, Cert, Key, Config) -> + {_, ServerNode, _} = ssl_test_lib:run_where(Config), + Server = ssl_test_lib:start_server([{node, ServerNode}, {port, 0}, + {from, self()}, + {mfa, {ssl_test_lib, + send_recv_result_active, + []}}, + {options, + [{verify, verify_peer}, {cacertfile, CA}, + {certfile, Cert}, {keyfile, Key}]}]), + {Server, ssl_test_lib:inet_port(Server)}. + +check_result(Server, erlang, Client, erlang) -> + ssl_test_lib:check_result(Server, ok, Client, ok); +check_result(Server, erlang, _, _) -> + ssl_test_lib:check_result(Server, ok); +check_result(_, _, Client, erlang) -> + ssl_test_lib:check_result(Client, ok); +check_result(_,openssl, _, openssl) -> + ok. + +openssl_check(erlang, Config) -> + Config; +openssl_check(_, Config) -> + TLSVersion = ?config(tls_version, Config), + case ssl_test_lib:check_sane_openssl_version(TLSVersion) of + true -> + ssl:start(), + Config; + false -> + {skip, "TLS version not supported by openssl"} + end. + diff --git a/lib/ssl/test/ssl_ECC_SUITE_data/CA.pem b/lib/ssl/test/ssl_ECC_SUITE_data/CA.pem new file mode 100644 index 0000000000..f82efdefc5 --- /dev/null +++ b/lib/ssl/test/ssl_ECC_SUITE_data/CA.pem @@ -0,0 +1,14 @@ +-----BEGIN CERTIFICATE----- +MIICGjCCAYegAwIBAgIQZIIqq4RXfpBKJXV69Jc4BjAJBgUrDgMCHQUAMB0xGzAZ +BgNVBAMTEklTQSBUZXN0IEF1dGhvcml0eTAeFw0xMjAzMjAxNzEzMjFaFw0zOTEy +MzEyMzU5NTlaMB0xGzAZBgNVBAMTEklTQSBUZXN0IEF1dGhvcml0eTCBnzANBgkq +hkiG9w0BAQEFAAOBjQAwgYkCgYEAqnt6FSyFQVSDyP7mY63IhCzgysTxBEg1qDb8 +nBHj9REReZA5UQ5iyEOdTbdLyOaSk2rJyA2wdTjYkNnLzK49nZFlpf89r3/bakAM +wZv69S3FJi9W2z9m4JPv/5+QCYnFNRSnnHw3maNElwoQyknx96I3W7EuVOvKtKhh +4DaD0WsCAwEAAaNjMGEwDwYDVR0TAQH/BAUwAwEB/zBOBgNVHQEERzBFgBBCHwn2 +8AmbN+cvJl1iJ1bsoR8wHTEbMBkGA1UEAxMSSVNBIFRlc3QgQXV0aG9yaXR5ghBk +giqrhFd+kEoldXr0lzgGMAkGBSsOAwIdBQADgYEAIlVecua5Cr1z/cdwQ8znlgOU +U+y/uzg0nupKkopzVnRYhwV4hxZt3izAz4C/SJZB7eL0bUKlg1ceGjbQsGEm0fzF +LEV3vym4G51bxv03Iecwo96G4NgjJ7+9/7ciBVzfxZyfuCpYG1M2LyrbOyuevtTy +2+vIueT0lv6UftgBfIE= +-----END CERTIFICATE----- diff --git a/lib/ssl/test/ssl_ECC_SUITE_data/ec1.crt b/lib/ssl/test/ssl_ECC_SUITE_data/ec1.crt new file mode 100644 index 0000000000..7d2b9cde9d --- /dev/null +++ b/lib/ssl/test/ssl_ECC_SUITE_data/ec1.crt @@ -0,0 +1,11 @@ +-----BEGIN CERTIFICATE----- +MIIBhjCB8AIBBjANBgkqhkiG9w0BAQUFADAdMRswGQYDVQQDExJJU0EgVGVzdCBB +dXRob3JpdHkwHhcNMTMwODA4MTAxNDI3WhcNMjMwODA2MTAxNDI3WjBFMQswCQYD +VQQGEwJVUzERMA8GA1UECBMIVmlyZ2luaWExFTATBgNVBAcTDEZvcnQgQmVsdm9p +cjEMMAoGA1UEAxMDZWMxMFYwEAYHKoZIzj0CAQYFK4EEAAoDQgAEpiRIxUCESROR +P8IByg+vBv1fDdAg7yXfAh95GxFtvhBqZs6ATwaRKyLmZYgUm/4NUAyUeqmTBb7s +2msKo5mnNzANBgkqhkiG9w0BAQUFAAOBgQAmwzoB1DVO69FQOUdBVnyups4t0c1c +8h+1z/5P4EtPltk4o3mRn0AZogqdXCpNbuSGbSJh+dep5xW30VLxNHdc+tZSLK6j +pT7A3hymMk8qbi13hxeH/VpEP25y1EjHowow9Wmb6ebtT/v7qFQ9AAHD9ONcIM4I +FCC8vdFo7M5GgQ== +-----END CERTIFICATE----- diff --git a/lib/ssl/test/ssl_ECC_SUITE_data/ec1.key b/lib/ssl/test/ssl_ECC_SUITE_data/ec1.key new file mode 100644 index 0000000000..2dc9508b3c --- /dev/null +++ b/lib/ssl/test/ssl_ECC_SUITE_data/ec1.key @@ -0,0 +1,8 @@ +-----BEGIN EC PARAMETERS----- +BgUrgQQACg== +-----END EC PARAMETERS----- +-----BEGIN EC PRIVATE KEY----- +MHQCAQEEIOO0WK8znNzLyZIoGRIlaKnCNr2Wy8uk9i+GGFIhDGNAoAcGBSuBBAAK +oUQDQgAEpiRIxUCESRORP8IByg+vBv1fDdAg7yXfAh95GxFtvhBqZs6ATwaRKyLm +ZYgUm/4NUAyUeqmTBb7s2msKo5mnNw== +-----END EC PRIVATE KEY----- diff --git a/lib/ssl/test/ssl_ECC_SUITE_data/ec2.crt b/lib/ssl/test/ssl_ECC_SUITE_data/ec2.crt new file mode 100644 index 0000000000..b0558a0ebc --- /dev/null +++ b/lib/ssl/test/ssl_ECC_SUITE_data/ec2.crt @@ -0,0 +1,11 @@ +-----BEGIN CERTIFICATE----- +MIIBhjCB8AIBBzANBgkqhkiG9w0BAQUFADAdMRswGQYDVQQDExJJU0EgVGVzdCBB +dXRob3JpdHkwHhcNMTMwODA4MTAxNDM0WhcNMjMwODA2MTAxNDM0WjBFMQswCQYD +VQQGEwJVUzERMA8GA1UECBMIVmlyZ2luaWExFTATBgNVBAcTDEZvcnQgQmVsdm9p +cjEMMAoGA1UEAxMDZWMyMFYwEAYHKoZIzj0CAQYFK4EEAAoDQgAEzXaYReUyvoYl +FwGOe0MJEXWCUncMfr2xG4GMjGYlfZsvLGEokefsJIvW+I+9jgUT2UFjxFXYNAvm +uD1A1iWVWjANBgkqhkiG9w0BAQUFAAOBgQBFa6iIlrT9DWptIdB8uSYvp7qwiHxN +hiVH5YhGIHHqjGZqtRHrSxqNEYMXXrgH9Hxc6gDbk9PsHZyVVoh/HgVWddqW1inh +tStZm420PAKCuH4T6Cfsk76GE2m7FRzJvw9TM1f2A5nIy9abyrpup8lZGcIL4Kmq +1Fix1LRtrmLNTA== +-----END CERTIFICATE----- diff --git a/lib/ssl/test/ssl_ECC_SUITE_data/ec2.key b/lib/ssl/test/ssl_ECC_SUITE_data/ec2.key new file mode 100644 index 0000000000..366d13648b --- /dev/null +++ b/lib/ssl/test/ssl_ECC_SUITE_data/ec2.key @@ -0,0 +1,8 @@ +-----BEGIN EC PARAMETERS----- +BgUrgQQACg== +-----END EC PARAMETERS----- +-----BEGIN EC PRIVATE KEY----- +MHQCAQEEIPR3ORUpAFMTQhUJ0jllN38LKWziG8yP2H54Y/9vh1PwoAcGBSuBBAAK +oUQDQgAEzXaYReUyvoYlFwGOe0MJEXWCUncMfr2xG4GMjGYlfZsvLGEokefsJIvW ++I+9jgUT2UFjxFXYNAvmuD1A1iWVWg== +-----END EC PRIVATE KEY----- diff --git a/lib/ssl/test/ssl_ECC_SUITE_data/rsa1.crt b/lib/ssl/test/ssl_ECC_SUITE_data/rsa1.crt new file mode 100644 index 0000000000..ed9beacf68 --- /dev/null +++ b/lib/ssl/test/ssl_ECC_SUITE_data/rsa1.crt @@ -0,0 +1,20 @@ +-----BEGIN CERTIFICATE----- +MIIDVjCCAr8CAQkwDQYJKoZIhvcNAQEFBQAwHTEbMBkGA1UEAxMSSVNBIFRlc3Qg +QXV0aG9yaXR5MB4XDTEzMDgwODEwMTUzNFoXDTQwMTIyNDEwMTUzNFowRjELMAkG +A1UEBhMCVVMxETAPBgNVBAgTCFZpcmdpbmlhMRUwEwYDVQQHEwxGb3J0IEJlbHZv +aXIxDTALBgNVBAMTBHJzYTEwggIiMA0GCSqGSIb3DQEBAQUAA4ICDwAwggIKAoIC +AQC62v40w1AjV3oJuyYC2Fw6XhTOi1il6xZFnB9J1WhCmuxAB/VMhBcNypx38mNk +eQ7a/ERQ5ddhZey29DYeFYU8oqfDURgWx5USHufb90xBen9KPmX3VNuQ8ZFP2q8Q +b01/oRHBJQRBuaCtFHzpGIVBjC6dD5yeQgJsYaF4u+PBbonsIGROXMybcvUzXmjU +dwpy2NhjGQL5sWcOdIeRP43APSyRYvq4tuBUZk2XxWfBcvA8LpcoYPMlRTf6jGL1 +/fAAcCYJ9lh3h92w0NZ/7ZRa/ebTplxK6yqCftuSKui1KdL69m0WZqHl79AUSfs9 +lsOwx9lHkyYvJeMofyeDbZ+3OYLmVqEBG1fza2aV2XVh9zJ8fAwmXy/c2IDhw/oD +HAe/rSg/Sgt03ydIKqtZHbl3v0EexQQRlJRULIzdtON02dJMUd4EFUgQ9OUtEmC2 +Psj9Jdu1g5cevU7Mymu8Ot+fjHiGTcBUsXNuXFCbON3Gw7cIDl4+iv+cpDHHVC9L +HK3PMEq3vu3qOGXSz+LDOoqkfROcLG7BclBuN2zoVSsMHFkB4aJhwy7eHhGz0z2W +c6LTVd+GAApdY80kmjOjT//QxHEsX/n1useHza3OszQqZiArr4ub4rtq+l1DxAS/ +DWrZ/JGsbKL8cjWso6qBF94xTi8WhjkKuUYhsm+qLAbNOQIDAQABMA0GCSqGSIb3 +DQEBBQUAA4GBAIcuzqRkfypV/9Z85ZQCCoejPm5Urhv7dfg1/B3QtazogPBZLgL5 +e60fG1uAw5GmqTViHLvW06z73oQvJrFkrCLVvadDNtrKYKXnXqdkgVyk36F/B737 +A43HGnMfSxCfRhIOuKZB9clP5PiNlhw36yi3DratqT6TUvI69hg8a7jA +-----END CERTIFICATE----- diff --git a/lib/ssl/test/ssl_ECC_SUITE_data/rsa1.key b/lib/ssl/test/ssl_ECC_SUITE_data/rsa1.key new file mode 100644 index 0000000000..6e0d913d79 --- /dev/null +++ b/lib/ssl/test/ssl_ECC_SUITE_data/rsa1.key @@ -0,0 +1,51 @@ +-----BEGIN RSA PRIVATE KEY----- +MIIJKAIBAAKCAgEAutr+NMNQI1d6CbsmAthcOl4UzotYpesWRZwfSdVoQprsQAf1 +TIQXDcqcd/JjZHkO2vxEUOXXYWXstvQ2HhWFPKKnw1EYFseVEh7n2/dMQXp/Sj5l +91TbkPGRT9qvEG9Nf6ERwSUEQbmgrRR86RiFQYwunQ+cnkICbGGheLvjwW6J7CBk +TlzMm3L1M15o1HcKctjYYxkC+bFnDnSHkT+NwD0skWL6uLbgVGZNl8VnwXLwPC6X +KGDzJUU3+oxi9f3wAHAmCfZYd4fdsNDWf+2UWv3m06ZcSusqgn7bkirotSnS+vZt +Fmah5e/QFEn7PZbDsMfZR5MmLyXjKH8ng22ftzmC5lahARtX82tmldl1YfcyfHwM +Jl8v3NiA4cP6AxwHv60oP0oLdN8nSCqrWR25d79BHsUEEZSUVCyM3bTjdNnSTFHe +BBVIEPTlLRJgtj7I/SXbtYOXHr1OzMprvDrfn4x4hk3AVLFzblxQmzjdxsO3CA5e +Por/nKQxx1QvSxytzzBKt77t6jhl0s/iwzqKpH0TnCxuwXJQbjds6FUrDBxZAeGi +YcMu3h4Rs9M9lnOi01XfhgAKXWPNJJozo0//0MRxLF/59brHh82tzrM0KmYgK6+L +m+K7avpdQ8QEvw1q2fyRrGyi/HI1rKOqgRfeMU4vFoY5CrlGIbJvqiwGzTkCAwEA +AQKCAgBkXyaWKSRvF5pSh9lPRfGk2MzMdkXUOofoNIkKHDy5KocljiDSTVIk8mVC +eU2ytuSn9UKtQgmEJEAXtu8rEdxUSftcC7+o3OTSqw9ZNWoc8jRWKVaUmVyoa1rn +Tk0jwuYaXOcwnTXAKHqK/qpqe+V45FhVvgEfcc3jcj5OoH8jdMFZubyn62ltRz83 +rMsa9icCskDqWpEil40IUshP2ZfHYBUEs+qCNpoiPCIKGNw3KgqqCUzhP9LcfmYn +jCnMge/eDGAikdXLv4vyYvwWFATRK/pGTuLcy542IvbHeY0vY5wVezH2CoOFBGD9 +xQ/UcZwE5hVtQToNsYhoRIVxL/3Of0qDk1M6W2Plh2MAstyejIHE3ct0pPfW3rsu +j/9Z/H0P9Q5ghSjarwOp2qGrrz6/4LVbbTDY8V1L928l4SqbUMtEQxcxTBN8YFoD +mPV3Jc3zls9wiiEX53RcH8MK5tjrcRwWqurTZvi/pkLfXlGDgKGCOaa3HgWVQyU+ +L6jVZM+u1nwN+jNXQYGeLEro/6tvG8WQbRMHQoxLG+rm4V3/SwH0DcfrVFDTg+i6 +3wMU1GC/aQEdTFWXvHAkpwrf4M9QWvjtheiaSxtBUoAY6l+ixCVHKrIk6glKLEjx +92HxmcJdopQScFETAyg8eVKV0kOGfVeFEpIqwq7hVedmTflpQQKCAQEA44h4dAta +cYeBqBr8eljWcgs79gmgwBEQxQUnwE/zuzLKn5NxAW324Kh25V/n/MupUzBlLPWn +91UHfw9PCXT8/HvgYQ4S5sXbKRbGmuPSsTmz4Rfe2ix6RggVNUOwORVNDyM7SQh7 +USdzZH5dMxKfF5L/b4Byx7eQZaoeKlfaXcqgikNZZ6pkhVCNxUKi9vvjS9r2wwCd +xtgu5MfTpdEci0zH1+uuRisVRcEbcRX9umUTCiZrmEeddZXNiwTAS3FtX7qGzuq9 +LKIeETwcOZrWj0E48UvbSfK4Axn7sf5J0n7/Qo7I089S5QQEI6ZDP501i71dNFhn +qfcY30c1k3TC7QKCAQEA0juuVHExKNLLNmQejNPfuHYoH0Uk2BH/8x96/Mkj6k6K +SUCHDS3iWOljXGw8YtpS8v5mGBGgMhJ+s/vCRM6R9eXYTc8u2ktY/kjyW0PgW8/Z +vb9VrQpn5svTNwj2Q8qYsTqXnQKO7YuL+hnQpQNAcID6FTeOASVLGObEf810qRfN +4y3RqCWUnYXXTyXj+cJdbXTxfF7HVZPIAQKqE7J5Qo9ynYILY62oSmUGC6m8VKyE +rrvDMK1IVi0X4w+Jx4HX0IC2+DBKxCaLWT69bE1IwjB06Q5zoTQPVi6c6qQp7K0H +kqSyLJ/ctwcEubu0DPNmvMlgWtAbAsoESA5GbIit/QKCAQEAxRzp9OYNAUM6AK74 +QOmLRZsT4+6tUxa1p2jy6fiZlnfG731kra9c630mG0n9iJPK6aWIUO20CGGiL+HM +P84YiIaseIgfucp4NV1kyrRJR31MptjuF6Xme5ru/IjaNmmMq2uDJZ7ybfi2T73k +8aTVLDANl8P4K6qLrnc00MvxAcXTVFRKNLN5h8CkQNqcoUjPvVxA3+g9xxBrd4jh +gsnoZ4kpq5WiEWmrcRV8t3gsqfh8CRQFrBOGhmIzgZapG/J0pTTLKqBTKEJ9t8KS +VRkdfVcshGWJ4MMjxJQS5zz7KR8Z9cgKlOwLzRiwmU2k/owr4hY3k2xuyeClrHBd +KpRBdQKCAQBvDk/dE55gbloi9WieBB6eluxC+IeqDHgkunCBsM9kKvEqGQg+kgqL +5V4zqImNvr8q1fCgrk7tpI+CDHBnYKgCOdS15cheUIdGbMp6I7UVSws/DR/5NRIF +/Y4p+HX/Abr/hHAq5PsTyS+8gn6RbNJRnBB/vMUrHcQ5902+JY6G9KgyZjXmmVOU +kutWSDHR8jbgZ3JZvMeYEWUKA5pMpW8hFh35zoStt0K7afpzlsqCAFBm7ZEC2cbo +nxGLRN4HojObVSNSoFAepi3eiyINYBYbXvWjV5sFgTbI0/7YhLgQ6qahdJcas6go +l3CLnPhUDxAqkkZwMpbSNl1kowXYt6sRAoIBAAOWnXgf9Bdb9OWKGgt42gVfC4cz +zj2JoLpbDTtbEdHNn8XQvPhGbpdtgnsuEMijIMy1UTlmv17jbFWdZTDeN31EUJrC +smgKX0OlVFKD90AI0BiIREK0hJUBV0pV4JoUjwnQBHGvranD06/wAtHEqgqF1Ipp +DCAKwxggM7qtB1R1vkrc/aLQej+mlwA8N6q92rnEsg+EnEbhtLDDZQcV/q5cSDCN +MMcnM+QdyjKwEeCVXHaqNfeSqKg/Ab2eZbS9VxA+XZD73+eUY/JeJsg7LfZrRz0T +ij5LCS7A+nVB5/B5tGkk4fcNhk2n356be6l46S98BEgtuwGLC9pqXf7zyp4= +-----END RSA PRIVATE KEY----- diff --git a/lib/ssl/test/ssl_ECC_SUITE_data/rsa2.crt b/lib/ssl/test/ssl_ECC_SUITE_data/rsa2.crt new file mode 100644 index 0000000000..06ca92dda3 --- /dev/null +++ b/lib/ssl/test/ssl_ECC_SUITE_data/rsa2.crt @@ -0,0 +1,20 @@ +-----BEGIN CERTIFICATE----- +MIIDVjCCAr8CAQowDQYJKoZIhvcNAQEFBQAwHTEbMBkGA1UEAxMSSVNBIFRlc3Qg +QXV0aG9yaXR5MB4XDTEzMDgwODEwMTYwMloXDTQwMTIyNDEwMTYwMlowRjELMAkG +A1UEBhMCVVMxETAPBgNVBAgTCFZpcmdpbmlhMRUwEwYDVQQHEwxGb3J0IEJlbHZv +aXIxDTALBgNVBAMTBHJzYTIwggIiMA0GCSqGSIb3DQEBAQUAA4ICDwAwggIKAoIC +AQCjQUe0BGOpULjOAmLbXM4SSQzJvxJbCFi3tryyd+OARq6Fdp6/fslVhsr0PhWE +X8yRbAugIjseTpLwz+1OC6LavOGV1ixzGTI/9HDXGKbf8qoCrSdh28sqQJnmqGT4 +UCKLn6Rqjg2iyBBcSK3LrtKEPI4C7NaSOZUtANkppvziEMwm+0r16sgHh2Xx6mxd +22q01kq1lJqwEnIDPMSz3+ESUVQQ4T3ka7yFIhc9PYmILIXkZi0x7AiDeRkIILul +GQrduTWSPGY3prXeDAbmQNazxrHp8fcR2AfFSI6HYxMALq9jWxc4xDIkss6BO2Et +riJOIgXFpbyVsYCbkI1kXhEWFDt3uJBIcmtJKGzro4xv+XLG6BbUeTJgSHXMc7Cb +fX87+CBIFR5a/aqkEKh/mcvsDdaV+kpNKdr7q4wAuIQb8g7IyXEDuAm1VZjQs9WC +KFRGSq9sergEw9gna0iThRZjD+dzNzB17XmlAK4wa98a7MntwqpAt/GsCFOiPM8E +c+8gpuo8WqC0kP8OpImyw9cQhlZ3dca1qkr2cyKyAOGxUxyA67FgiHSsxJJ2Xhse +o49qeKTjMZd8zhSokM2TH6qEf7YfOePU51YRfAHUhzRmE31N/MExqDjFjklksEtM +iHhbPo+cOoxV8x1u13umdUvtTaAUSBA/DpvzWdnORvnaqQIDAQABMA0GCSqGSIb3 +DQEBBQUAA4GBAFD+O7h+5R5S1rIN9eC+oEGpvRhMG4v4G3pJp+c7bbtO7ifFx1WP +bta1b5YtiQYcKP0ORABm/3Kcvsb3VbaMH/zkxWEbASZsmIcBY3ml4f2kkn6WT2hD +Wc6VMIAR3N6Mj1b30yI1qYVIid+zIouiykMB+zqllm+Uar0SPNjKxDU/ +-----END CERTIFICATE----- diff --git a/lib/ssl/test/ssl_ECC_SUITE_data/rsa2.key b/lib/ssl/test/ssl_ECC_SUITE_data/rsa2.key new file mode 100644 index 0000000000..d415ef0391 --- /dev/null +++ b/lib/ssl/test/ssl_ECC_SUITE_data/rsa2.key @@ -0,0 +1,51 @@ +-----BEGIN RSA PRIVATE KEY----- +MIIJJwIBAAKCAgEAo0FHtARjqVC4zgJi21zOEkkMyb8SWwhYt7a8snfjgEauhXae +v37JVYbK9D4VhF/MkWwLoCI7Hk6S8M/tTgui2rzhldYscxkyP/Rw1xim3/KqAq0n +YdvLKkCZ5qhk+FAii5+kao4NosgQXEity67ShDyOAuzWkjmVLQDZKab84hDMJvtK +9erIB4dl8epsXdtqtNZKtZSasBJyAzzEs9/hElFUEOE95Gu8hSIXPT2JiCyF5GYt +MewIg3kZCCC7pRkK3bk1kjxmN6a13gwG5kDWs8ax6fH3EdgHxUiOh2MTAC6vY1sX +OMQyJLLOgTthLa4iTiIFxaW8lbGAm5CNZF4RFhQ7d7iQSHJrSShs66OMb/lyxugW +1HkyYEh1zHOwm31/O/ggSBUeWv2qpBCof5nL7A3WlfpKTSna+6uMALiEG/IOyMlx +A7gJtVWY0LPVgihURkqvbHq4BMPYJ2tIk4UWYw/nczcwde15pQCuMGvfGuzJ7cKq +QLfxrAhTojzPBHPvIKbqPFqgtJD/DqSJssPXEIZWd3XGtapK9nMisgDhsVMcgOux +YIh0rMSSdl4bHqOPanik4zGXfM4UqJDNkx+qhH+2Hznj1OdWEXwB1Ic0ZhN9TfzB +Mag4xY5JZLBLTIh4Wz6PnDqMVfMdbtd7pnVL7U2gFEgQPw6b81nZzkb52qkCAwEA +AQKCAgBORLHXwHL3bdfsDIDQooG5ioQzBQQL2MiP63A0L/5GNZzeJ6ycKnDkLCeJ +SWqPeE5fOemo8EBfm1QfV9BxpmqBbCTK7U+KLv5EYzDmLs9ydqjDd7h11iZlL2uZ +hgpCckjdn7/3xfsLm9ccJ0wLZtlOxKlhBaMpn6nBVbLHoWOEDoGR/tBFbjZQRb2+ +aaFirhtOb56Jx6ER4QYAP1Ye1qrVWWBwZ0yBApXzThDOL36MZqwagFISqRK71YcG +uoq78HGhM3ZXkdV/wNFYj3OPWG6W6h/KBVNqnqO7FbofdoRZhghYHgfYE1fm+ELA ++nLwr5eK1gzmYTs0mVELRBZFlEOkCfYNOnuRgysFezEklS+ICp3HzIhYXza3kyTf +B2ZBwZZVCv/94MKyibyANErmv1a5ugY5Hsn9/WKC8qTto+qLYoyFCvBjzj0PSaVX +/3cty2DY0SK16K1Y4AOPtJMYTXYB3tVX8Akgjz1F6REBtZSOXrSQ3Vhy1ORl3Hzf +WCBYDqL8K0hJiBVgkvneIyIjmFHsdM60Nr7EldBEnJ/UrPzsl2VuWFPZlnasfUaW +x+vq1H4Dfz+bHt8coBRHDjKgUvwkfFeBQOBR5DG3vMrxguVRA1EYYMRR5C3yxk2m +ARAtdh4VxUQDQjjrmr7Dl/y1rU34aInXIrrFWpuvIhl8Ht09sQKCAQEA1pXKK5f0 +HkKfM/qk5xzF+WdHClBrPXi0XwLN6UQ+WWMMNhkGZ+FMPXl/6IJDT91s6DA3tPhr +OZF64n9ZFaGgHNBXNiB+Txjv5vZeSBMFt3hSonqt42aijx6gXfmLnkA+TYpa6Wex +YCeEgdH8LocJa7Gj2vzrYliPYk3deh6SnZZ6N8bI+ciwK3ZGF/pkWaTX83dIFq3w +YyZ+0dEpNGbA9812wNVourPg3OfqG3/CdnTfvY1M9KCC3JalpyzQL4Zm5soXF0wj +36C2yTxA02AyFz3TvUIBrvsN6i0gmGfE79+UIp29JYrFRsIgBDt+ze2vQWUz2MX5 +GeX6/yCBgiTXtwKCAQEAwsNf6k2m5Cw+WtuLzzUfBBJCN+t1lrnYJ6lF0HubW6TZ +vX1kBWyc+Rpo4ljr/+f4R9aC/gTEQOmV/hNVZy1RU2dAI8cH+r6JWG9lgif+8h// +5R81txE7gnuK1Na7PmvnQPPN661zsQZ5e1ENPXS3TJmUW/M01JxAMqEQjvAPa/II +H2KjL5NX28k9Hiw9rP6n+qXAfG/LEwXgoVCcehPwfANqQ1l95UgOdKDmjG94dipI +h2DEK70ZbrsgQbT60Wd8I5h0yhiQsik2/bVkqLmcG4SSg0/5cf2vZMApgoH/adUz +rJFdthm7iGPLhwS6fbhXew17Af96FvzfkifUV+cgnwKCAQBNUlYyFSQKz1jMgxFu +kciokNVhWw75bIgaAEmwNz38OZuJ1sSfI+iz8hbr8hxNJ+15UP6RwD3q1YghG2A/ +Uij+mPgD8ftxhvvTDo10jR4vOTUVhP0phq8mwRNqKWRs1ptcl3Egz5NzoWm22bJ0 +FYaIfs8bNq2el2i7NHGM8n1EOZe6h2+dyfno/0pMk5YbUzHZce7Q9UY8g/+InUSq +tCfuYuPaokuFkxGAqDSMSiIJSx3gEI1dTIU69TGlppkxts1XdhSR+YanqyKSKpr1 +T6FdDJNCjAlNQvuFmVM4d5PYF4kqXApu/60MTSD6RXHwxCe1ecEP6G5VLbCew9jG +y33LAoIBAGsWyC9pwQEm/qYwn4AwYjx32acrtX1J9HtiTLvkqzjJvNu/DXcaEHm7 +tr32TNVp9A9z+JS5hDt49Hs+oC/aMCRe2lqRvmZ1y8kvfy4A1eLGC4stDPj65bDK +QzziURRyejYxmCElPz6wI63VlCUdfwgEThn88SiSPY5ZF2SwxJoC+8peDwJCzwVP +cmabxtHPOAfOibciNRPhoHCyhUdunUVjD1O26k1ewGwKaJoBVMgMWdLuNw8hq9FB +3OukGmF3uD9OPbE9rpn3pX/89Dr9y8MpsvG20J6H8Z/BNVHILus/SmlxiIhvP7kv +viIgTHaCHL/RWrhvg+8N3dRcSBqJQFsCggEAFe2TMEq2AlnBn4gsuAOIuZPYKQCg +2a+tl1grQzmNth6AGGQcIqShadICD6SnVMIS64HHV/m18Cuz7GhJ06ZVjXJsHueG +UpTE9wAmI2LxnNkupkLJu+SVcW3N86PujWmQBFpHkd+IRPLS51xjD9W5zLJ7HL4/ +fnKO+B+ZK6Imxbe5C5vJezkGfeOSyQoVtt6MT/XtSKNEGPBX+M6fLKgUMMg2H2Mt +/SsD7DkOzFteKXzaEg/K8oOTpsOPkVDwNl2KErlEqbJv0k7yEVw50mYmsn/OLjh8 ++9EibISwCODbPxB+PhV6u2ue1IvGLRqtsN60lFOvbGn+kSewy9EUVHHQDQ== +-----END RSA PRIVATE KEY----- diff --git a/lib/ssl/test/ssl_basic_SUITE.erl b/lib/ssl/test/ssl_basic_SUITE.erl index b5cf6d1212..b8849d5cbd 100644 --- a/lib/ssl/test/ssl_basic_SUITE.erl +++ b/lib/ssl/test/ssl_basic_SUITE.erl @@ -212,21 +212,20 @@ end_per_suite(_Config) -> %%-------------------------------------------------------------------- init_per_group(GroupName, Config) -> - case ssl_test_lib:is_tls_version(GroupName) of + case ssl_test_lib:is_tls_version(GroupName) andalso ssl_test_lib:sufficient_crypto_support(GroupName) of true -> + ssl_test_lib:init_tls_version(GroupName), + Config; + _ -> case ssl_test_lib:sufficient_crypto_support(GroupName) of true -> - ssl_test_lib:init_tls_version(GroupName), + ssl:start(), Config; false -> {skip, "Missing crypto support"} - end; - _ -> - ssl:start(), - Config + end end. - end_per_group(_GroupName, Config) -> Config. diff --git a/lib/ssl/test/ssl_test_lib.erl b/lib/ssl/test/ssl_test_lib.erl index 34c52b10b3..74fadc0cc7 100644 --- a/lib/ssl/test/ssl_test_lib.erl +++ b/lib/ssl/test/ssl_test_lib.erl @@ -27,6 +27,7 @@ -compile(export_all). -record(sslsocket, { fd = nil, pid = nil}). +-define(SLEEP, 1000). %% For now always run locally run_where(_) -> @@ -949,7 +950,10 @@ init_tls_version(Version) -> sufficient_crypto_support('tlsv1.2') -> CryptoSupport = crypto:supports(), proplists:get_bool(sha256, proplists:get_value(hashs, CryptoSupport)); -sufficient_crypto_support(ciphers_ec) -> +sufficient_crypto_support(Group) when Group == ciphers_ec; %% From ssl_basic_SUITE + Group == erlang_server; %% From ssl_ECC_SUITE + Group == erlang_client; %% From ssl_ECC_SUITE + Group == erlang -> %% From ssl_ECC_SUITE CryptoSupport = crypto:supports(), proplists:get_bool(ecdh, proplists:get_value(public_keys, CryptoSupport)); sufficient_crypto_support(_) -> @@ -1026,3 +1030,39 @@ cipher_restriction(Config0) -> true -> Config0 end. + +check_sane_openssl_version(Version) -> + case {Version, os:cmd("openssl version")} of + {_, "OpenSSL 1.0.1" ++ _} -> + true; + {'tlsv1.2', "OpenSSL 1.0" ++ _} -> + false; + {'tlsv1.1', "OpenSSL 1.0" ++ _} -> + false; + {'tlsv1.2', "OpenSSL 0" ++ _} -> + false; + {'tlsv1.1', "OpenSSL 0" ++ _} -> + false; + {_, _} -> + true + end. + +wait_for_openssl_server() -> + receive + {Port, {data, Debug}} when is_port(Port) -> + ct:log("openssl ~s~n",[Debug]), + %% openssl has started make sure + %% it will be in accept. Parsing + %% output is too error prone. (Even + %% more so than sleep!) + ct:sleep(?SLEEP) + end. + +version_flag(tlsv1) -> + " -tls1 "; +version_flag('tlsv1.1') -> + " -tls1_1 "; +version_flag('tlsv1.2') -> + " -tls1_2 "; +version_flag(sslv3) -> + " -ssl3 ". diff --git a/lib/ssl/test/ssl_to_openssl_SUITE.erl b/lib/ssl/test/ssl_to_openssl_SUITE.erl index 019ed58b1b..b576b8f70d 100644 --- a/lib/ssl/test/ssl_to_openssl_SUITE.erl +++ b/lib/ssl/test/ssl_to_openssl_SUITE.erl @@ -120,7 +120,7 @@ end_per_suite(_Config) -> init_per_group(GroupName, Config) -> case ssl_test_lib:is_tls_version(GroupName) of true -> - case check_sane_openssl_version(GroupName) of + case ssl_test_lib:check_sane_openssl_version(GroupName) of true -> ssl_test_lib:init_tls_version(GroupName), Config; @@ -204,7 +204,7 @@ basic_erlang_client_openssl_server(Config) when is_list(Config) -> OpensslPort = open_port({spawn, Cmd}, [stderr_to_stdout]), - wait_for_openssl_server(), + ssl_test_lib:wait_for_openssl_server(), Client = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, {host, Hostname}, @@ -269,14 +269,14 @@ erlang_client_openssl_server(Config) when is_list(Config) -> CertFile = proplists:get_value(certfile, ServerOpts), KeyFile = proplists:get_value(keyfile, ServerOpts), Version = tls_record:protocol_version(tls_record:highest_protocol_version([])), - Cmd = "openssl s_server -accept " ++ integer_to_list(Port) ++ version_flag(Version) ++ + Cmd = "openssl s_server -accept " ++ integer_to_list(Port) ++ ssl_test_lib:version_flag(Version) ++ " -cert " ++ CertFile ++ " -key " ++ KeyFile, ct:log("openssl cmd: ~p~n", [Cmd]), OpensslPort = open_port({spawn, Cmd}, [stderr_to_stdout]), - wait_for_openssl_server(), + ssl_test_lib:wait_for_openssl_server(), Client = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, {host, Hostname}, @@ -311,7 +311,7 @@ erlang_server_openssl_client(Config) when is_list(Config) -> Port = ssl_test_lib:inet_port(Server), Version = tls_record:protocol_version(tls_record:highest_protocol_version([])), - Cmd = "openssl s_client -port " ++ integer_to_list(Port) ++ version_flag(Version) ++ + Cmd = "openssl s_client -port " ++ integer_to_list(Port) ++ ssl_test_lib:version_flag(Version) ++ " -host localhost", ct:log("openssl cmd: ~p~n", [Cmd]), @@ -345,7 +345,7 @@ erlang_client_openssl_server_dsa_cert(Config) when is_list(Config) -> KeyFile = proplists:get_value(keyfile, ServerOpts), Version = tls_record:protocol_version(tls_record:highest_protocol_version([])), - Cmd = "openssl s_server -accept " ++ integer_to_list(Port) ++ version_flag(Version) ++ + Cmd = "openssl s_server -accept " ++ integer_to_list(Port) ++ ssl_test_lib:version_flag(Version) ++ " -cert " ++ CertFile ++ " -CAfile " ++ CaCertFile ++ " -key " ++ KeyFile ++ " -Verify 2 -msg", @@ -353,7 +353,7 @@ erlang_client_openssl_server_dsa_cert(Config) when is_list(Config) -> OpensslPort = open_port({spawn, Cmd}, [stderr_to_stdout]), - wait_for_openssl_server(), + ssl_test_lib:wait_for_openssl_server(), Client = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, {host, Hostname}, @@ -392,7 +392,7 @@ erlang_server_openssl_client_dsa_cert(Config) when is_list(Config) -> {options, ServerOpts}]), Port = ssl_test_lib:inet_port(Server), Version = tls_record:protocol_version(tls_record:highest_protocol_version([])), - Cmd = "openssl s_client -port " ++ integer_to_list(Port) ++ version_flag(Version) ++ + Cmd = "openssl s_client -port " ++ integer_to_list(Port) ++ ssl_test_lib:version_flag(Version) ++ " -host localhost " ++ " -cert " ++ CertFile ++ " -CAfile " ++ CaCertFile ++ " -key " ++ KeyFile ++ " -msg", @@ -428,7 +428,7 @@ erlang_server_openssl_client_reuse_session(Config) when is_list(Config) -> {options, ServerOpts}]), Port = ssl_test_lib:inet_port(Server), Version = tls_record:protocol_version(tls_record:highest_protocol_version([])), - Cmd = "openssl s_client -port " ++ integer_to_list(Port) ++ version_flag(Version) ++ + Cmd = "openssl s_client -port " ++ integer_to_list(Port) ++ ssl_test_lib:version_flag(Version) ++ " -host localhost -reconnect", ct:log("openssl cmd: ~p~n", [Cmd]), @@ -464,14 +464,14 @@ erlang_client_openssl_server_renegotiate(Config) when is_list(Config) -> KeyFile = proplists:get_value(keyfile, ServerOpts), Version = tls_record:protocol_version(tls_record:highest_protocol_version([])), - Cmd = "openssl s_server -accept " ++ integer_to_list(Port) ++ version_flag(Version) ++ + Cmd = "openssl s_server -accept " ++ integer_to_list(Port) ++ ssl_test_lib:version_flag(Version) ++ " -cert " ++ CertFile ++ " -key " ++ KeyFile ++ " -msg", ct:log("openssl cmd: ~p~n", [Cmd]), OpensslPort = open_port({spawn, Cmd}, [stderr_to_stdout]), - wait_for_openssl_server(), + ssl_test_lib:wait_for_openssl_server(), Client = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, {host, Hostname}, @@ -513,14 +513,14 @@ erlang_client_openssl_server_nowrap_seqnum(Config) when is_list(Config) -> CertFile = proplists:get_value(certfile, ServerOpts), KeyFile = proplists:get_value(keyfile, ServerOpts), Version = tls_record:protocol_version(tls_record:highest_protocol_version([])), - Cmd = "openssl s_server -accept " ++ integer_to_list(Port) ++ version_flag(Version) ++ + Cmd = "openssl s_server -accept " ++ integer_to_list(Port) ++ ssl_test_lib:version_flag(Version) ++ " -cert " ++ CertFile ++ " -key " ++ KeyFile ++ " -msg", ct:log("openssl cmd: ~p~n", [Cmd]), OpensslPort = open_port({spawn, Cmd}, [stderr_to_stdout]), - wait_for_openssl_server(), + ssl_test_lib:wait_for_openssl_server(), Client = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, {host, Hostname}, @@ -559,7 +559,7 @@ erlang_server_openssl_client_nowrap_seqnum(Config) when is_list(Config) -> {options, [{renegotiate_at, N}, {reuse_sessions, false} | ServerOpts]}]), Port = ssl_test_lib:inet_port(Server), Version = tls_record:protocol_version(tls_record:highest_protocol_version([])), - Cmd = "openssl s_client -port " ++ integer_to_list(Port) ++ version_flag(Version) ++ + Cmd = "openssl s_client -port " ++ integer_to_list(Port) ++ ssl_test_lib:version_flag(Version) ++ " -host localhost -msg", ct:log("openssl cmd: ~p~n", [Cmd]), @@ -594,14 +594,14 @@ erlang_client_openssl_server_no_server_ca_cert(Config) when is_list(Config) -> CertFile = proplists:get_value(certfile, ServerOpts), KeyFile = proplists:get_value(keyfile, ServerOpts), Version = tls_record:protocol_version(tls_record:highest_protocol_version([])), - Cmd = "openssl s_server -accept " ++ integer_to_list(Port) ++ version_flag(Version) ++ + Cmd = "openssl s_server -accept " ++ integer_to_list(Port) ++ ssl_test_lib:version_flag(Version) ++ " -cert " ++ CertFile ++ " -key " ++ KeyFile ++ " -msg", ct:log("openssl cmd: ~p~n", [Cmd]), OpensslPort = open_port({spawn, Cmd}, [stderr_to_stdout]), - wait_for_openssl_server(), + ssl_test_lib:wait_for_openssl_server(), Client = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, {host, Hostname}, @@ -636,7 +636,7 @@ erlang_client_openssl_server_client_cert(Config) when is_list(Config) -> CaCertFile = proplists:get_value(cacertfile, ServerOpts), KeyFile = proplists:get_value(keyfile, ServerOpts), Version = tls_record:protocol_version(tls_record:highest_protocol_version([])), - Cmd = "openssl s_server -accept " ++ integer_to_list(Port) ++ version_flag(Version) ++ + Cmd = "openssl s_server -accept " ++ integer_to_list(Port) ++ ssl_test_lib:version_flag(Version) ++ " -cert " ++ CertFile ++ " -CAfile " ++ CaCertFile ++ " -key " ++ KeyFile ++ " -Verify 2", @@ -644,7 +644,7 @@ erlang_client_openssl_server_client_cert(Config) when is_list(Config) -> OpensslPort = open_port({spawn, Cmd}, [stderr_to_stdout]), - wait_for_openssl_server(), + ssl_test_lib:wait_for_openssl_server(), Client = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, {host, Hostname}, @@ -688,7 +688,7 @@ erlang_server_openssl_client_client_cert(Config) when is_list(Config) -> KeyFile = proplists:get_value(keyfile, ClientOpts), Version = tls_record:protocol_version(tls_record:highest_protocol_version([])), Cmd = "openssl s_client -cert " ++ CertFile ++ " -CAfile " ++ CaCertFile - ++ " -key " ++ KeyFile ++ " -port " ++ integer_to_list(Port) ++ version_flag(Version) ++ + ++ " -key " ++ KeyFile ++ " -port " ++ integer_to_list(Port) ++ ssl_test_lib:version_flag(Version) ++ " -host localhost", ct:log("openssl cmd: ~p~n", [Cmd]), @@ -776,14 +776,14 @@ erlang_client_bad_openssl_server(Config) when is_list(Config) -> CertFile = proplists:get_value(certfile, ServerOpts), KeyFile = proplists:get_value(keyfile, ServerOpts), Version = tls_record:protocol_version(tls_record:highest_protocol_version([])), - Cmd = "openssl s_server -accept " ++ integer_to_list(Port) ++ version_flag(Version) ++ + Cmd = "openssl s_server -accept " ++ integer_to_list(Port) ++ ssl_test_lib:version_flag(Version) ++ " -cert " ++ CertFile ++ " -key " ++ KeyFile ++ "", ct:log("openssl cmd: ~p~n", [Cmd]), OpensslPort = open_port({spawn, Cmd}, [stderr_to_stdout]), - wait_for_openssl_server(), + ssl_test_lib:wait_for_openssl_server(), Client0 = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, {host, Hostname}, @@ -839,7 +839,7 @@ expired_session(Config) when is_list(Config) -> OpensslPort = open_port({spawn, Cmd}, [stderr_to_stdout]), - wait_for_openssl_server(), + ssl_test_lib:wait_for_openssl_server(), Client0 = ssl_test_lib:start_client([{node, ClientNode}, @@ -1033,14 +1033,14 @@ cipher(CipherSuite, Version, Config, ClientOpts, ServerOpts) -> CertFile = proplists:get_value(certfile, ServerOpts), KeyFile = proplists:get_value(keyfile, ServerOpts), - Cmd = "openssl s_server -accept " ++ integer_to_list(Port) ++ version_flag(Version) ++ + Cmd = "openssl s_server -accept " ++ integer_to_list(Port) ++ ssl_test_lib:version_flag(Version) ++ " -cert " ++ CertFile ++ " -key " ++ KeyFile ++ "", ct:log("openssl cmd: ~p~n", [Cmd]), OpenSslPort = open_port({spawn, Cmd}, [stderr_to_stdout]), - wait_for_openssl_server(), + ssl_test_lib:wait_for_openssl_server(), ConnectionInfo = {ok, {Version, CipherSuite}}, @@ -1097,14 +1097,14 @@ start_erlang_client_and_openssl_server_with_opts(Config, ErlangClientOpts, Opens Version = tls_record:protocol_version(tls_record:highest_protocol_version([])), Cmd = "openssl s_server " ++ OpensslServerOpts ++ " -accept " ++ - integer_to_list(Port) ++ version_flag(Version) ++ + integer_to_list(Port) ++ ssl_test_lib:version_flag(Version) ++ " -cert " ++ CertFile ++ " -key " ++ KeyFile, ct:log("openssl cmd: ~p~n", [Cmd]), OpensslPort = open_port({spawn, Cmd}, [stderr_to_stdout]), - wait_for_openssl_server(), + ssl_test_lib:wait_for_openssl_server(), Client = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, {host, Hostname}, @@ -1136,14 +1136,14 @@ start_erlang_client_and_openssl_server_for_npn_negotiation(Config, Data, Callbac KeyFile = proplists:get_value(keyfile, ServerOpts), Version = tls_record:protocol_version(tls_record:highest_protocol_version([])), - Cmd = "openssl s_server -msg -nextprotoneg http/1.1,spdy/2 -accept " ++ integer_to_list(Port) ++ version_flag(Version) ++ + Cmd = "openssl s_server -msg -nextprotoneg http/1.1,spdy/2 -accept " ++ integer_to_list(Port) ++ ssl_test_lib:version_flag(Version) ++ " -cert " ++ CertFile ++ " -key " ++ KeyFile, ct:log("openssl cmd: ~p~n", [Cmd]), OpensslPort = open_port({spawn, Cmd}, [stderr_to_stdout]), - wait_for_openssl_server(), + ssl_test_lib:wait_for_openssl_server(), Client = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, {host, Hostname}, @@ -1174,7 +1174,7 @@ start_erlang_server_and_openssl_client_for_npn_negotiation(Config, Data, Callbac {options, ServerOpts}]), Port = ssl_test_lib:inet_port(Server), Version = tls_record:protocol_version(tls_record:highest_protocol_version([])), - Cmd = "openssl s_client -nextprotoneg http/1.0,spdy/2 -msg -port " ++ integer_to_list(Port) ++ version_flag(Version) ++ + Cmd = "openssl s_client -nextprotoneg http/1.0,spdy/2 -msg -port " ++ integer_to_list(Port) ++ ssl_test_lib:version_flag(Version) ++ " -host localhost", ct:log("openssl cmd: ~p~n", [Cmd]), @@ -1203,7 +1203,7 @@ start_erlang_server_and_openssl_client_with_opts(Config, ErlangServerOpts, OpenS {options, ServerOpts}]), Port = ssl_test_lib:inet_port(Server), Version = tls_record:protocol_version(tls_record:highest_protocol_version([])), - Cmd = "openssl s_client " ++ OpenSSLClientOpts ++ " -msg -port " ++ integer_to_list(Port) ++ version_flag(Version) ++ + Cmd = "openssl s_client " ++ OpenSSLClientOpts ++ " -msg -port " ++ integer_to_list(Port) ++ ssl_test_lib:version_flag(Version) ++ " -host localhost", ct:log("openssl cmd: ~p~n", [Cmd]), @@ -1302,25 +1302,6 @@ server_sent_garbage(Socket) -> end. -wait_for_openssl_server() -> - receive - {Port, {data, Debug}} when is_port(Port) -> - ct:log("openssl ~s~n",[Debug]), - %% openssl has started make sure - %% it will be in accept. Parsing - %% output is too error prone. (Even - %% more so than sleep!) - ct:sleep(?SLEEP) - end. - -version_flag(tlsv1) -> - " -tls1 "; -version_flag('tlsv1.1') -> - " -tls1_1 "; -version_flag('tlsv1.2') -> - " -tls1_2 "; -version_flag(sslv3) -> - " -ssl3 ". check_openssl_npn_support(Config) -> HelpText = os:cmd("openssl s_client --help"), @@ -1365,18 +1346,3 @@ supports_sslv2(Port) -> true end. -check_sane_openssl_version(Version) -> - case {Version, os:cmd("openssl version")} of - {_, "OpenSSL 1.0.1" ++ _} -> - true; - {'tlsv1.2', "OpenSSL 1.0" ++ _} -> - false; - {'tlsv1.1', "OpenSSL 1.0" ++ _} -> - false; - {'tlsv1.2', "OpenSSL 0" ++ _} -> - false; - {'tlsv1.1', "OpenSSL 0" ++ _} -> - false; - {_, _} -> - true - end. diff --git a/lib/stdlib/src/erl_lint.erl b/lib/stdlib/src/erl_lint.erl index 8f07750b9b..f599881c07 100644 --- a/lib/stdlib/src/erl_lint.erl +++ b/lib/stdlib/src/erl_lint.erl @@ -1953,12 +1953,10 @@ expr({string,_Line,_S}, _Vt, St) -> {[],St}; expr({nil,_Line}, _Vt, St) -> {[],St}; expr({cons,_Line,H,T}, Vt, St) -> expr_list([H,T], Vt, St); -expr({lc,_Line,E,Qs}, Vt0, St0) -> - {Vt,St} = handle_comprehension(E, Qs, Vt0, St0), - {vtold(Vt, Vt0),St}; %Don't export local variables -expr({bc,_Line,E,Qs}, Vt0, St0) -> - {Vt,St} = handle_comprehension(E, Qs, Vt0, St0), - {vtold(Vt,Vt0),St}; %Don't export local variables +expr({lc,_Line,E,Qs}, Vt, St) -> + handle_comprehension(E, Qs, Vt, St); +expr({bc,_Line,E,Qs}, Vt, St) -> + handle_comprehension(E, Qs, Vt, St); expr({tuple,_Line,Es}, Vt, St) -> expr_list(Es, Vt, St); expr({record_index,Line,Name,Field}, _Vt, St) -> @@ -2012,8 +2010,7 @@ expr({'fun',Line,Body}, Vt, St) -> %%No one can think funs export! case Body of {clauses,Cs} -> - {Bvt, St1} = fun_clauses(Cs, Vt, St), - {vtupdate(Bvt, Vt), St1}; + fun_clauses(Cs, Vt, St); {function,F,A} -> %% BifClash - Fun expression %% N.B. Only allows BIFs here as well, NO IMPORTS!! @@ -2111,12 +2108,12 @@ expr({'try',Line,Es,Scs,Ccs,As}, Vt, St0) -> {Evt0,St1} = exprs(Es, Vt, St0), TryLine = {'try',Line}, Uvt = vtunsafe(vtnames(vtnew(Evt0, Vt)), TryLine, []), - Evt1 = vtupdate(Uvt, vtupdate(Evt0, Vt)), - {Sccs,St2} = icrt_clauses(Scs++Ccs, TryLine, Evt1, St1), + Evt1 = vtupdate(Uvt, vtsubtract(Evt0, Uvt)), + {Sccs,St2} = icrt_clauses(Scs++Ccs, TryLine, vtupdate(Evt1, Vt), St1), Rvt0 = Sccs, Rvt1 = vtupdate(vtunsafe(vtnames(vtnew(Rvt0, Vt)), TryLine, []), Rvt0), Evt2 = vtmerge(Evt1, Rvt1), - {Avt0,St} = exprs(As, Evt2, St2), + {Avt0,St} = exprs(As, vtupdate(Evt2, Vt), St2), Avt1 = vtupdate(vtunsafe(vtnames(vtnew(Avt0, Vt)), TryLine, []), Avt0), Avt = vtmerge(Evt2, Avt1), {Avt,St}; @@ -2150,10 +2147,11 @@ expr({remote,Line,_M,_F}, _Vt, St) -> %% {UsedVarTable,State} expr_list(Es, Vt, St) -> - foldl(fun (E, {Esvt,St0}) -> - {Evt,St1} = expr(E, Vt, St0), - {vtmerge(Evt, Esvt),St1} - end, {[],St}, Es). + {Vt1,St1} = foldl(fun (E, {Esvt,St0}) -> + {Evt,St1} = expr(E, Vt, St0), + {vtmerge_pat(Evt, Esvt),St1} + end, {[],St}, Es), + {vtmerge(vtnew(Vt1, Vt), vtold(Vt1, Vt)),St1}. record_expr(Line, Rec, Vt, St0) -> St1 = warn_invalid_record(Line, Rec, St0), @@ -2310,7 +2308,7 @@ check_fields(Fs, Name, Fields, Vt, St0, CheckFun) -> check_field({record_field,Lf,{atom,La,F},Val}, Name, Fields, Vt, St, Sfs, CheckFun) -> case member(F, Sfs) of - true -> {Sfs,{Vt,add_error(Lf, {redefine_field,Name,F}, St)}}; + true -> {Sfs,{[],add_error(Lf, {redefine_field,Name,F}, St)}}; false -> {[F|Sfs], case find_field(F, Fields) of @@ -2843,7 +2841,9 @@ icrt_export(Csvt, Vt, In, St) -> Uvt = vtmerge(Evt, Unused), %% Make exported and unsafe unused variables unused in subsequent code: Vt2 = vtmerge(Uvt, vtsubtract(Vt1, Uvt)), - {Vt2,St}. + %% Forget about old variables which were not used: + Vt3 = vtmerge(vtnew(Vt2, Vt), vt_no_unused(vtold(Vt2, Vt))), + {Vt3,St}. handle_comprehension(E, Qs, Vt0, St0) -> {Vt1, Uvt, St1} = lc_quals(Qs, Vt0, St0), @@ -2856,7 +2856,11 @@ handle_comprehension(E, Qs, Vt0, St0) -> %% Local variables that have not been shadowed. {_,St} = check_unused_vars(Vt2, Vt0, St4), Vt3 = vtmerge(vtsubtract(Vt2, Uvt), Uvt), - {Vt3,St}. + %% Don't export local variables. + Vt4 = vtold(Vt3, Vt0), + %% Forget about old variables which were not used. + Vt5 = vt_no_unused(Vt4), + {Vt5,St}. %% lc_quals(Qualifiers, ImportVarTable, State) -> %% {VarTable,ShadowedVarTable,State} @@ -2920,7 +2924,7 @@ fun_clauses(Cs, Vt, St) -> {Cvt,St1} = fun_clause(C, Vt, St0), {vtmerge(Cvt, Bvt0),St1} end, {[],St#lint{recdef_top = false}}, Cs), - {Bvt,St2#lint{recdef_top = OldRecDef}}. + {vt_no_unused(vtold(Bvt, Vt)),St2#lint{recdef_top = OldRecDef}}. fun_clause({clause,_Line,H,G,B}, Vt0, St0) -> {Hvt,Binvt,St1} = head(H, Vt0, [], St0), % No imported pattern variables @@ -3181,6 +3185,8 @@ vt_no_unsafe(Vt) -> [V || {_,{S,_U,_L}}=V <- Vt, _ -> true end]. +vt_no_unused(Vt) -> [V || {_,{_,U,_L}}=V <- Vt, U =/= unused]. + %% vunion(VarTable1, VarTable2) -> [VarName]. %% vunion([VarTable]) -> [VarName]. %% vintersection(VarTable1, VarTable2) -> [VarName]. diff --git a/lib/stdlib/test/erl_lint_SUITE.erl b/lib/stdlib/test/erl_lint_SUITE.erl index 4dc7a44064..48ddeac478 100644 --- a/lib/stdlib/test/erl_lint_SUITE.erl +++ b/lib/stdlib/test/erl_lint_SUITE.erl @@ -151,7 +151,16 @@ unused_vars_warn_basic(Config) when is_list(Config) -> {22,erl_lint,{unused_var,'N'}}, {23,erl_lint,{shadowed_var,'N','fun'}}, {28,erl_lint,{unused_var,'B'}}, - {29,erl_lint,{unused_var,'B'}}]}}], + {29,erl_lint,{unused_var,'B'}}]}}, + {basic2, + <<"-record(r, {x,y}). + f({X,Y}) -> {Z=X,Z=Y}; + f([H|T]) -> [Z=H|Z=T]; + f(#r{x=X,y=Y}) -> #r{x=A=X,y=A=Y}. + g({M, F}) -> (Z=M):(Z=F)(); + g({M, F, Arg}) -> (Z=M):F(Z=Arg). + h(X, Y) -> (Z=X) + (Z=Y).">>, + [warn_unused_vars], []}], ?line [] = run(Config, Ts), ok. @@ -537,7 +546,29 @@ unused_vars_warn_rec(Config) when is_list(Config) -> end. ">>, [warn_unused_vars], - {warnings,[{22,erl_lint,{unused_var,'Same'}}]}}], + {warnings,[{22,erl_lint,{unused_var,'Same'}}]}}, + {rec2, + <<"-record(r, {a,b}). + f(X, Y) -> #r{a=[K || K <- Y], b=[K || K <- Y]}. + g(X, Y) -> #r{a=lists:map(fun (K) -> K end, Y), + b=lists:map(fun (K) -> K end, Y)}. + h(X, Y) -> #r{a=case Y of _ when is_list(Y) -> Y end, + b=case Y of _ when is_list(Y) -> Y end}. + i(X, Y) -> #r{a=if is_list(Y) -> Y end, b=if is_list(Y) -> Y end}. + ">>, + [warn_unused_vars], + {warnings,[{2,erl_lint,{unused_var,'X'}}, + {3,erl_lint,{unused_var,'X'}}, + {5,erl_lint,{unused_var,'X'}}, + {7,erl_lint,{unused_var,'X'}}]}}, + {rec3, + <<"-record(r, {a}). + t() -> X = 1, #r{a=foo, a=bar, a=qux}. + ">>, + [warn_unused_vars], + {error,[{2,erl_lint,{redefine_field,r,a}}, + {2,erl_lint,{redefine_field,r,a}}], + [{2,erl_lint,{unused_var,'X'}}]}}], ?line [] = run(Config, Ts), ok. @@ -1075,7 +1106,24 @@ unsafe_vars_try(Config) when is_list(Config) -> {10,erl_lint,{unsafe_var,'Ra',{'try',3}}}, {10,erl_lint,{unsafe_var,'Rc',{'try',3}}}, {10,erl_lint,{unsafe_var,'Ro',{'try',3}}}], - []}}], + []}}, + {unsafe_try5, + <<"bang() -> + case 1 of + nil -> + Acc = 2; + _ -> + try + Acc = 3, + Acc + catch _:_ -> + ok + end + end, + Acc. + ">>, + [], + {errors,[{13,erl_lint,{unsafe_var,'Acc',{'try',6}}}],[]}}], ?line [] = run(Config, Ts), ok. diff --git a/lib/test_server/src/Makefile b/lib/test_server/src/Makefile index ebc5f5b71b..ab4dd4d95d 100644 --- a/lib/test_server/src/Makefile +++ b/lib/test_server/src/Makefile @@ -45,7 +45,6 @@ MODULES= test_server_ctrl \ test_server_node \ test_server \ test_server_sup \ - test_server_h \ erl2html2 TS_MODULES= \ diff --git a/lib/test_server/src/test_server.app.src b/lib/test_server/src/test_server.app.src index 163f370a47..42e78ed279 100644 --- a/lib/test_server/src/test_server.app.src +++ b/lib/test_server/src/test_server.app.src @@ -23,7 +23,6 @@ erl2html2, test_server_ctrl, test_server, - test_server_h, test_server_io, test_server_node, test_server_sup diff --git a/lib/test_server/src/test_server.erl b/lib/test_server/src/test_server.erl index c350f758ce..6ddb2b615f 100644 --- a/lib/test_server/src/test_server.erl +++ b/lib/test_server/src/test_server.erl @@ -389,7 +389,6 @@ run_test_case_apply({CaseNum,Mod,Func,Args,Name, os:putenv("VALGRIND_LOGFILE_INFIX",atom_to_list(Mod)++"."++ atom_to_list(Func)++"-") end, - test_server_h:testcase({Mod,Func,1}), ProcBef = erlang:system_info(process_count), Result = run_test_case_apply(Mod, Func, Args, Name, RunInit, TimetrapData), diff --git a/lib/test_server/src/test_server_ctrl.erl b/lib/test_server/src/test_server_ctrl.erl index ffa21d054c..d0f31af198 100644 --- a/lib/test_server/src/test_server_ctrl.erl +++ b/lib/test_server/src/test_server_ctrl.erl @@ -479,12 +479,6 @@ init([]) -> test_server_sup:call_trace(TraceSpec) end, process_flag(trap_exit, true), - case lists:keysearch(sasl, 1, application:which_applications()) of - {value,_} -> - test_server_h:install(); - false -> - ok - end, %% copy format_exception setting from init arg to application environment case init:get_argument(test_server_format_exception) of {ok,[[TSFE]]} -> @@ -1067,12 +1061,6 @@ terminate(_Reason, State) -> end, kill_all_jobs(State#state.jobs), test_server_node:kill_nodes(), - case lists:keysearch(sasl, 1, application:which_applications()) of - {value,_} -> - test_server_h:restore(); - _ -> - ok - end, ok. kill_all_jobs([{_Name,JobPid}|Jobs]) -> @@ -1183,7 +1171,13 @@ init_tester(Mod, Func, Args, Dir, Name, {_,_,MinLev}=Levels, "<td>~.3fs</td><td><b>~ts</b></td><td>~w Ok, ~w Failed~ts of ~w</td></tr>\n" "</tfoot>\n", [Time,SuccessStr,OkN,FailedN,SkipStr,OkN+FailedN+SkippedN]), - test_server_io:stop([major,html,unexpected_io]). + + test_server_io:stop([major,html,unexpected_io]), + {UnexpectedIoName,UnexpectedIoFooter} = get(test_server_unexpected_footer), + {ok,UnexpectedIoFd} = open_html_file(UnexpectedIoName, [append]), + io:put_chars(UnexpectedIoFd, "\n</pre>\n"++UnexpectedIoFooter), + file:close(UnexpectedIoFd), + ok. report_severe_error(Reason) -> test_server_sup:framework_call(report, [severe_error,Reason]). @@ -1642,15 +1636,13 @@ start_log_file() -> FilenameMode), ok = write_file(?last_file, TestDir1 ++ "\n", FilenameMode), put(test_server_log_dir_base,TestDir1), + MajorName = filename:join(TestDir1, ?suitelog_name), HtmlName = MajorName ++ ?html_ext, UnexpectedName = filename:join(TestDir1, ?unexpected_io_log), + {ok,Major} = open_utf8_file(MajorName), {ok,Html} = open_html_file(HtmlName), - {ok,Unexpected} = open_html_file(UnexpectedName), - test_server_io:set_fd(major, Major), - test_server_io:set_fd(html, Html), - test_server_io:set_fd(unexpected_io, Unexpected), {UnexpHeader,UnexpFooter} = case test_server_sup:framework_call(get_html_wrapper, @@ -1663,8 +1655,17 @@ start_log_file() -> {xhtml,UH,UF} -> {UH,UF} end, - io:put_chars(Unexpected, UnexpHeader++"\n<pre>\n"), - put(test_server_unexpected_footer,UnexpFooter), + + {ok,Unexpected} = open_html_file(UnexpectedName), + io:put_chars(Unexpected, [UnexpHeader, + xhtml("<br>\n<h2>Unexpected I/O</h2>", + "<br />\n<h3>Unexpected I/O</h3>"), + "\n<pre>\n"]), + put(test_server_unexpected_footer,{UnexpectedName,UnexpFooter}), + + test_server_io:set_fd(major, Major), + test_server_io:set_fd(html, Html), + test_server_io:set_fd(unexpected_io, Unexpected), make_html_link(filename:absname(?last_test ++ ?html_ext), HtmlName, filename:basename(Dir)), @@ -5299,6 +5300,9 @@ html_header(Title) -> open_html_file(File) -> open_utf8_file(File). +open_html_file(File,Opts) -> + open_utf8_file(File,Opts). + write_html_file(File,Content) -> write_file(File,Content,utf8). @@ -5307,6 +5311,9 @@ write_html_file(File,Content) -> open_utf8_file(File) -> file:open(File,[write,{encoding,utf8}]). +open_utf8_file(File,Opts) -> + file:open(File,[{encoding,utf8}|Opts]). + %% Write a file with specified encoding write_file(File,Content,latin1) -> file:write_file(File,Content); diff --git a/lib/test_server/src/test_server_h.erl b/lib/test_server/src/test_server_h.erl deleted file mode 100644 index 24063ddb10..0000000000 --- a/lib/test_server/src/test_server_h.erl +++ /dev/null @@ -1,148 +0,0 @@ -%% -%% %CopyrightBegin% -%% -%% Copyright Ericsson AB 2005-2013. 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 -%% compliance with the License. You should have received a copy of the -%% Erlang Public License along with this software. If not, it can be -%% retrieved online at http://www.erlang.org/. -%% -%% Software distributed under the License is distributed on an "AS IS" -%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See -%% the License for the specific language governing rights and limitations -%% under the License. -%% -%% %CopyrightEnd% -%% - --module(test_server_h). --behaviour(gen_event). - -%% API --export([install/0, restore/0]). --export([testcase/1]). - -%% gen_event callbacks --export([init/1, handle_event/2, handle_call/2, - handle_info/2, terminate/2, code_change/3]). - --record(state, {kernel, sasl, testcase}). - -%%==================================================================== -%% API -%%==================================================================== - -install() -> - case gen_event:add_handler(error_logger, ?MODULE, []) of - ok -> - error_logger:delete_report_handler(sasl_report_tty_h), - gen_event:delete_handler(error_logger, error_logger_tty_h, []), - ok; - Error -> - Error - end. - -restore() -> - gen_event:add_handler(error_logger, error_logger_tty_h, []), - error_logger:add_report_handler(sasl_report_tty_h, all), - gen_event:delete_handler(error_logger, ?MODULE, []). - -testcase(Testcase) -> - gen_event:call(error_logger, ?MODULE, {set_testcase, Testcase}, 10*60*1000). - -%%==================================================================== -%% gen_event callbacks -%%==================================================================== - -init([]) -> - - %% error_logger_tty_h initialization - User = set_group_leader(), - - %% sasl_report_tty_h initialization - Type = all, - - {ok, #state{kernel={User, []}, sasl=Type}}. - -set_group_leader() -> - case whereis(user) of - User when is_pid(User) -> - link(User), - group_leader(User, self()), - User; - _ -> - false - end. - -handle_event({_Type, GL, _Msg}, State) when node(GL)/=node() -> - {ok, State}; -handle_event({Tag, _GL, {_Pid, Type, _Report}} = Event, State) -> - SASL = lists:keyfind(sasl, 1, application:which_applications()), - case report_receiver(Tag, Type) of - sasl when SASL /= false -> - {ok,ErrLogType} = application:get_env(sasl, errlog_type), - SReport = sasl_report:format_report(group_leader(), ErrLogType, - tag_event(Event)), - if is_list(SReport) -> - tag(State#state.testcase), - sasl_report_tty_h:handle_event(Event, - State#state.sasl); - true -> %% Report is an atom if no logging is to be done - ignore - end; - sasl -> %% SASL not running - ignore; - kernel -> - tag(State#state.testcase), - error_logger_tty_h:handle_event(Event, State#state.kernel); - none -> - ignore - end, - {ok, State}; -handle_event(_Event, State) -> - {ok, State}. - -handle_call({set_testcase, Testcase}, State) -> - {ok, ok, State#state{testcase=Testcase}}; -handle_call(_Query, _State) -> - {error, bad_query}. - -handle_info({emulator,GL,_Chars}=Event, State) when node(GL)==node() -> - tag(State#state.testcase), - error_logger_tty_h:handle_info(Event, State#state.kernel), - {ok, State}; -handle_info(_Msg, State) -> - {ok, State}. - -terminate(_Reason, _State) -> - ok. - -code_change(_OldVsn, State, _Extra) -> - {ok, State}. - -report_receiver(error_report, supervisor_report) -> sasl; -report_receiver(error_report, crash_report) -> sasl; -report_receiver(info_report, progress) -> sasl; -report_receiver(error, _) -> kernel; -report_receiver(error_report, _) -> kernel; -report_receiver(warning_msg, _) -> kernel; -report_receiver(warning_report, _) -> kernel; -report_receiver(info, _) -> kernel; -report_receiver(info_msg, _) -> kernel; -report_receiver(info_report,Tuple) - when is_tuple(Tuple) andalso - (element(1,Tuple)==ct_connection orelse - element(1,Tuple)==conn_log) -> - none; -report_receiver(info_report, _) -> kernel; -report_receiver(_, _) -> none. - -tag({M,F,A}) when is_atom(M), is_atom(F), is_integer(A) -> - io:format(user, "~n=TESTCASE: ~w:~w/~w", [M,F,A]); -tag(Testcase) -> - io:format(user, "~n=TESTCASE: ~p", [Testcase]). - -tag_event(Event) -> - {calendar:local_time(), Event}. diff --git a/lib/test_server/src/test_server_io.erl b/lib/test_server/src/test_server_io.erl index 73d4468bda..62af3d5b28 100644 --- a/lib/test_server/src/test_server_io.erl +++ b/lib/test_server/src/test_server_io.erl @@ -32,27 +32,39 @@ -export([start_link/0,stop/1,get_gl/1,set_fd/2, start_transaction/0,end_transaction/0, print_buffered/1,print/3,print_unexpected/1, - set_footer/1,set_job_name/1,set_gl_props/1]). + set_footer/1,set_job_name/1,set_gl_props/1, + reset_state/0,finish/0]). -export([init/1,handle_call/3,handle_info/2,terminate/2]). --record(st, {fds, %Singleton fds (gb_tree) - shared_gl :: pid(), %Shared group leader - gls, %Group leaders (gb_set) - io_buffering=false, %I/O buffering - buffered, %Buffered I/O requests - html_footer, %HTML footer - job_name, %Name of current job. - gl_props, %Properties for GL. - stopping +-record(st, {fds, % Singleton fds (gb_tree) + tags=[], % Known tag types + shared_gl :: pid(), % Shared group leader + gls, % Group leaders (gb_set) + io_buffering=false, % I/O buffering + buffered, % Buffered I/O requests + html_footer, % HTML footer + job_name, % Name of current job. + gl_props, % Properties for GL + phase, % Indicates current mode + offline_buffer, % Buffer I/O during startup + stopping, % Reply to when process stopped + pending_ops % Perform when process idle }). start_link() -> - case gen_server:start_link({local,?MODULE}, ?MODULE, [], []) of - {ok,Pid} -> - {ok,Pid}; - Other -> - Other + case whereis(?MODULE) of + undefined -> + case gen_server:start_link({local,?MODULE}, ?MODULE, [], []) of + {ok,Pid} -> + {ok,Pid}; + Other -> + Other + end; + Pid -> + %% already running, reset the state + reset_state(), + {ok,Pid} end. stop(FilesToClose) -> @@ -62,6 +74,9 @@ stop(FilesToClose) -> group_leader(OldGL, self()), ok. +finish() -> + req(finish). + %% get_gl(Shared) -> Pid %% Shared = boolean() %% Pid = pid() @@ -142,19 +157,27 @@ set_footer(Footer) -> req({set_footer,Footer}). %% set_job_name(Name) +%% %% Set a name for the currently running job. The name will be used %% when printing to 'stdout'. %% + set_job_name(Name) -> req({set_job_name,Name}). %% set_gl_props(PropList) +%% %% Set properties for group leader processes. When a group_leader process %% is created, test_server_gl:set_props(PropList) will be called. set_gl_props(PropList) -> req({set_gl_props,PropList}). +%% reset_state +%% +%% Reset the initial state +reset_state() -> + req(reset_state). %%% Internal functions. @@ -167,7 +190,10 @@ init([]) -> buffered=Empty, html_footer="</body>\n</html>\n", job_name="<name not set>", - gl_props=[]}}. + gl_props=[], + phase=starting, + offline_buffer=[], + pending_ops=[]}}. req(Req) -> gen_server:call(?MODULE, Req, infinity). @@ -178,9 +204,24 @@ handle_call({get_gl,false}, _From, #st{gls=Gls,gl_props=Props}=St) -> {reply,Pid,St#st{gls=gb_sets:insert(Pid, Gls)}}; handle_call({get_gl,true}, _From, #st{shared_gl=Shared}=St) -> {reply,Shared,St}; -handle_call({set_fd,Tag,Fd}, _From, #st{fds=Fds0}=St) -> +handle_call({set_fd,Tag,Fd}, _From, #st{fds=Fds0,tags=Tags0, + offline_buffer=OfflineBuff}=St) -> Fds = gb_trees:enter(Tag, Fd, Fds0), - {reply,ok,St#st{fds=Fds}}; + St1 = St#st{fds=Fds,tags=[Tag|lists:delete(Tag, Tags0)]}, + OfflineBuff1 = + if OfflineBuff == [] -> + []; + true -> + %% Fd ready, print anything buffered for associated Tag + lists:filtermap(fun({T,From,Str}) when T == Tag -> + output(From, Tag, Str, St1), + false; + (_) -> + true + end, lists:reverse(OfflineBuff)) + end, + {reply,ok,St1#st{phase=started, + offline_buffer=lists:reverse(OfflineBuff1)}}; handle_call({start_transaction,Pid}, _From, #st{io_buffering=Buffer0, buffered=Buf0}=St) -> Buf = case gb_trees:is_defined(Pid, Buf0) of @@ -213,12 +254,15 @@ handle_call({set_job_name,Name}, _From, St) -> handle_call({set_gl_props,Props}, _From, #st{shared_gl=Shared}=St) -> test_server_gl:set_props(Shared, Props), {reply,ok,St#st{gl_props=Props}}; -handle_call({stop,FdTags}, From, #st{fds=Fds,shared_gl=SGL,gls=Gls0}=St0) -> - St = St0#st{gls=gb_sets:insert(SGL, Gls0),stopping=From}, - gc(St), - %% Give the users of the surviving group leaders some - %% time to finish. - erlang:send_after(2000, self(), stop_group_leaders), +handle_call(reset_state, From, #st{phase=stopping,pending_ops=Ops}=St) -> + %% can't reset during stopping phase, save op for later + Op = fun(NewSt) -> + {_,Result,NewSt1} = handle_call(reset_state, From, NewSt), + {Result,NewSt1} + end, + {noreply,St#st{pending_ops=[{From,Op}|Ops]}}; +handle_call(reset_state, _From, #st{fds=Fds,tags=Tags,gls=Gls, + offline_buffer=OfflineBuff}) -> %% close open log files lists:foreach(fun(Tag) -> case gb_trees:lookup(Tag, Fds) of @@ -227,8 +271,50 @@ handle_call({stop,FdTags}, From, #st{fds=Fds,shared_gl=SGL,gls=Gls0}=St0) -> {value,Fd} -> file:close(Fd) end - end, FdTags), - {noreply,St}. + end, Tags), + GlList = gb_sets:to_list(Gls), + [test_server_gl:stop(GL) || GL <- GlList], + timer:sleep(100), + case lists:filter(fun(GlPid) -> is_process_alive(GlPid) end, GlList) of + [] -> + ok; + _ -> + timer:sleep(2000), + [exit(GL, kill) || GL <- GlList] + end, + Empty = gb_trees:empty(), + {ok,Shared} = test_server_gl:start_link(), + {reply,ok,#st{fds=Empty,shared_gl=Shared,gls=gb_sets:empty(), + io_buffering=gb_sets:empty(), + buffered=Empty, + html_footer="</body>\n</html>\n", + job_name="<name not set>", + gl_props=[], + phase=starting, + offline_buffer=OfflineBuff, + pending_ops=[]}}; +handle_call({stop,FdTags}, From, #st{fds=Fds0,tags=Tags0, + shared_gl=SGL,gls=Gls0}=St0) -> + St = St0#st{gls=gb_sets:insert(SGL, Gls0),phase=stopping,stopping=From}, + gc(St), + %% close open log files + {Fds1,Tags1} = lists:foldl(fun(Tag, {Fds,Tags}) -> + case gb_trees:lookup(Tag, Fds) of + none -> + {Fds,Tags}; + {value,Fd} -> + file:close(Fd), + {gb_trees:delete(Tag, Fds), + lists:delete(Tag, Tags)} + end + end, {Fds0,Tags0}, FdTags), + %% Give the users of the surviving group leaders some + %% time to finish. + erlang:send_after(1000, self(), stop_group_leaders), + {noreply,St#st{fds=Fds1,tags=Tags1}}; +handle_call(finish, From, St) -> + gen_server:reply(From, ok), + {stop,normal,St}. handle_info({'EXIT',Pid,normal}, #st{gls=Gls0,stopping=From}=St) -> Gls = gb_sets:delete_any(Pid, Gls0), @@ -236,22 +322,40 @@ handle_info({'EXIT',Pid,normal}, #st{gls=Gls0,stopping=From}=St) -> true -> %% No more group leaders left. gen_server:reply(From, ok), - {stop,normal,St#st{gls=Gls,stopping=undefined}}; + {noreply,St#st{gls=Gls,phase=stopping,stopping=undefined}}; false -> %% Wait for more group leaders to finish. - {noreply,St#st{gls=Gls}} + {noreply,St#st{gls=Gls,phase=stopping}} end; handle_info({'EXIT',_Pid,Reason}, _St) -> exit(Reason); handle_info(stop_group_leaders, #st{gls=Gls}=St) -> %% Stop the remaining group leaders. - [test_server_gl:stop(GL) || GL <- gb_sets:to_list(Gls)], - erlang:send_after(2000, self(), kill_group_leaders), + GlPids = gb_sets:to_list(Gls), + [test_server_gl:stop(GL) || GL <- GlPids], + timer:sleep(100), + Wait = + case lists:filter(fun(GlPid) -> is_process_alive(GlPid) end, GlPids) of + [] -> 0; + _ -> 2000 + end, + erlang:send_after(Wait, self(), kill_group_leaders), {noreply,St}; -handle_info(kill_group_leaders, #st{gls=Gls,stopping=From}=St) -> +handle_info(kill_group_leaders, #st{gls=Gls,stopping=From, + pending_ops=Ops}=St) -> [exit(GL, kill) || GL <- gb_sets:to_list(Gls)], - gen_server:reply(From, ok), - {stop,normal,St}; + if From /= undefined -> + gen_server:reply(From, ok); + true -> % reply has been sent already + ok + end, + %% we're idle, check if any ops are pending + St1 = lists:foldr(fun({ReplyTo,Op},NewSt) -> + {Result,NewSt1} = Op(NewSt), + gen_server:reply(ReplyTo, Result), + NewSt1 + end, St#st{phase=idle,pending_ops=[]}, Ops), + {noreply,St1}; handle_info(Other, St) -> io:format("Ignoring: ~p\n", [Other]), {noreply,St}. @@ -259,11 +363,19 @@ handle_info(Other, St) -> terminate(_, _) -> ok. -output(From, Tag, Str, #st{io_buffering=Buffered,buffered=Buf0}=St) -> +output(From, Tag, Str, #st{io_buffering=Buffered,buffered=Buf0, + phase=Phase,offline_buffer=OfflineBuff}=St) -> case gb_sets:is_member(From, Buffered) of false -> - do_output(Tag, Str, St), - St; + case do_output(Tag, Str, Phase, St) of + buffer when length(OfflineBuff)>500 -> + %% something's wrong, clear buffer + St#st{offline_buffer=[]}; + buffer -> + St#st{offline_buffer=[{Tag,From,Str}|OfflineBuff]}; + _ -> + St + end; true -> Q0 = gb_trees:get(From, Buf0), Q = queue:in({Tag,Str}, Q0), @@ -271,17 +383,19 @@ output(From, Tag, Str, #st{io_buffering=Buffered,buffered=Buf0}=St) -> St#st{buffered=Buf} end. -do_output(stdout, Str, #st{job_name=undefined}) -> +do_output(stdout, Str, _, #st{job_name=undefined}) -> io:put_chars(Str); -do_output(stdout, Str0, #st{job_name=Name}) -> +do_output(stdout, Str0, _, #st{job_name=Name}) -> Str = io_lib:format("Testing ~ts: ~ts\n", [Name,Str0]), io:put_chars(Str); -do_output(Tag, Str, #st{fds=Fds}=St) -> +do_output(Tag, Str, Phase, #st{fds=Fds}=St) -> case gb_trees:lookup(Tag, Fds) of + none when Phase /= started -> + buffer; none -> S = io_lib:format("\n*** ERROR: ~w, line ~w: No known '~p' log file\n", [?MODULE,?LINE,Tag]), - do_output(stdout, [S,Str], St); + do_output(stdout, [S,Str], Phase, St); {value,Fd} -> try io:put_chars(Fd, Str), @@ -293,14 +407,14 @@ do_output(Tag, Str, #st{fds=Fds}=St) -> S = io_lib:format("\n*** ERROR: ~w, line ~w: Error writing to " "log file '~p': ~p\n", [?MODULE,?LINE,Tag,Error]), - do_output(stdout, [S,Str], St) + do_output(stdout, [S,Str], Phase, St) end end. finalise_table(Fd, #st{html_footer=Footer}) -> case file:position(Fd, {cur,0}) of {ok,Pos} -> - %% We are writing to a seekable file. Finalise so + %% We are writing to a seekable file. Finalise so %% we get complete valid (and viewable) HTML code. %% Then rewind to overwrite the finalising code. io:put_chars(Fd, ["\n</table>\n",Footer]), @@ -319,7 +433,7 @@ do_print_buffered(Q0, St) -> eot -> Q; {Tag,Str} -> - do_output(Tag, Str, St), + do_output(Tag, Str, undefined, St), do_print_buffered(Q, St) end. |