implement match.arg2()

Author: shikokuchuo

NEWS.md

@@ -13,7 +13,7 @@
 * Unified `send()` and `recv()` functions, and their asynchronous counterparts `send_aio()` and `recv_aio()`, are now S3 generics and can be used across Sockets, Contexts and Streams.
 * Revised 'block' argument for `send()` and `recv()` now allows an integer value for setting a timeout.
 * `send_ctx()` and `recv_ctx()` are deprecated and will be removed in a future package version - the methods for `send()` and `recv()` should be used instead.
-* To allow for more flexible practices, logging is now deprecated and being phased out. Logging can still be set via 'NANONEXT_LOG' prior to package load but `logging()` can no longer be used. Logging will be removed entirely in a future package version.
+* To allow for more flexible practices, logging is now deprecated and being phased out. Logging can still be set via 'NANONEXT_LOG' prior to package load but `logging()` can no longer be used. Logging will be removed entirely in the next package version.
 * Returned NNG error codes are now all classed as 'errorValue' across the package.
 
 # nanonext 0.3.0

R/aio.R

@@ -48,7 +48,7 @@ send_aio <- function(con, data, mode = c("serial", "raw"), timeout) UseMethod("s
 #'
 send_aio.nanoSocket <- function(con, data, mode = c("serial", "raw"), timeout) {
 
-  mode <- match.arg(mode)
+  mode <- match.arg2(mode, c("serial", "raw"))
   if (missing(timeout)) timeout <- -2L
   force(data)
   data <- encode(data = data, mode = mode)
@@ -78,7 +78,7 @@ send_aio.nanoSocket <- function(con, data, mode = c("serial", "raw"), timeout) {
 #'
 send_aio.nanoContext <- function(con, data, mode = c("serial", "raw"), timeout) {
 
-  mode <- match.arg(mode)
+  mode <- match.arg2(mode, c("serial", "raw"))
   if (missing(timeout)) timeout <- -2L
   force(data)
   data <- encode(data = data, mode = mode)
@@ -109,7 +109,7 @@ send_aio.nanoContext <- function(con, data, mode = c("serial", "raw"), timeout)
 send_aio.nanoStream <- function(con, data, mode = "raw", timeout) {
 
   force(data)
-  data <- encode(data = data, mode = "raw")
+  data <- encode(data = data, mode = 2L)
   if (missing(timeout)) timeout <- -2L
   aio <- .Call(rnng_stream_send_aio, con, data, timeout)
   is.integer(aio) && return(invisible(aio))
@@ -206,7 +206,8 @@ recv_aio.nanoSocket <- function(con,
                                 keep.raw = TRUE,
                                 ...) {
 
-  mode <- match.arg(mode)
+  mode <- match.arg2(mode, c("serial", "character", "complex", "double",
+                             "integer", "logical", "numeric", "raw"))
   keep.raw <- missing(keep.raw) || isTRUE(keep.raw)
   if (missing(timeout)) timeout <- -2L
   aio <- .Call(rnng_recv_aio, con, timeout)
@@ -282,7 +283,8 @@ recv_aio.nanoContext <- function(con,
                                  keep.raw = TRUE,
                                  ...) {
 
-  mode <- match.arg(mode)
+  mode <- match.arg2(mode, c("serial", "character", "complex", "double",
+                             "integer", "logical", "numeric", "raw"))
   keep.raw <- missing(keep.raw) || isTRUE(keep.raw)
   if (missing(timeout)) timeout <- -2L
   aio <- .Call(rnng_ctx_recv_aio, con, timeout)
@@ -359,7 +361,8 @@ recv_aio.nanoStream <- function(con,
                                 n = 10000,
                                 ...) {
 
-  mode <- match.arg(mode)
+  mode <- match.arg2(mode, c("character", "complex", "double", "integer",
+                             "logical", "numeric", "raw")) + 1L
   keep.raw <- missing(keep.raw) || isTRUE(keep.raw)
   if (missing(timeout)) timeout <- -2L
   aio <- .Call(rnng_stream_recv_aio, con, n, timeout)

R/context.R

@@ -114,8 +114,9 @@ reply <- function(context,
                   timeout,
                   ...) {
 
-  recv_mode <- match.arg(recv_mode)
-  send_mode <- match.arg(send_mode)
+  recv_mode <- match.arg2(recv_mode, c("serial", "character", "complex", "double",
+                                       "integer", "logical", "numeric", "raw"))
+  send_mode <- match.arg2(send_mode, c("serial", "raw"))
   if (missing(timeout)) timeout <- -2L
   res <- .Call(rnng_ctx_recv, context, timeout)
   is.integer(res) && return(invisible(res))
@@ -184,8 +185,9 @@ request <- function(context,
                     timeout,
                     keep.raw = TRUE) {
 
-  send_mode <- match.arg(send_mode)
-  recv_mode <- match.arg(recv_mode)
+  send_mode <- match.arg2(send_mode, c("serial", "raw"))
+  recv_mode <- match.arg2(recv_mode, c("serial", "character", "complex", "double",
+                                       "integer", "logical", "numeric", "raw"))
   keep.raw <- missing(keep.raw) || isTRUE(keep.raw)
   if (missing(timeout)) timeout <- -2L
   force(data)
@@ -278,7 +280,7 @@ request <- function(context,
 #'
 send_ctx <- function(context, data, mode = c("serial", "raw"), timeout, echo = TRUE) {
 
-  mode <- match.arg(mode)
+  mode <- match.arg2(mode, c("serial", "raw"))
   if (missing(timeout)) timeout <- -2L
   force(data)
   data <- encode(data = data, mode = mode)
@@ -321,7 +323,8 @@ recv_ctx <- function(context,
                      timeout,
                      keep.raw = TRUE) {
 
-  mode <- match.arg(mode)
+  mode <- match.arg2(mode, c("serial", "character", "complex", "double",
+                             "integer", "logical", "numeric", "raw"))
   if (missing(timeout)) timeout <- -2L
   res <- .Call(rnng_ctx_recv, context, timeout)
   is.integer(res) && return(invisible(res))

R/docs.R

@@ -37,22 +37,6 @@
 #'     block; instead if the message cannot be delivered for any reason it is
 #'     discarded.
 #'
-#' @section Pipeline (one-way pipe):
-#'
-#'     In the pipeline pattern, pushers distribute messages to pullers, hence
-#'     useful for solving producer/consumer problems.
-#'
-#'     If multiple peers are connected, the pattern attempts to distribute fairly.
-#'     Each message sent by a pusher will be sent to one of its peer pullers,
-#'     chosen in a round-robin fashion. This property makes this pattern useful
-#'     in load-balancing scenarios.
-#'
-#'     [protocol, push] The push protocol is one half of a pipeline pattern. The
-#'     other side is the pull protocol.
-#'
-#'     [protocol, pull] The pull protocol is one half of a pipeline pattern. The
-#'     other half is the push protocol.
-#'
 #' @section Request/Reply (I ask, you answer):
 #'
 #'     In a request/reply pattern, a requester sends a message to one replier,
@@ -70,6 +54,22 @@
 #'     This socket may be used to receive messages (requests), and then to send
 #'     replies. Generally a reply can only be sent after receiving a request.
 #'
+#' @section Pipeline (one-way pipe):
+#'
+#'     In the pipeline pattern, pushers distribute messages to pullers, hence
+#'     useful for solving producer/consumer problems.
+#'
+#'     If multiple peers are connected, the pattern attempts to distribute fairly.
+#'     Each message sent by a pusher will be sent to one of its peer pullers,
+#'     chosen in a round-robin fashion. This property makes this pattern useful
+#'     in load-balancing scenarios.
+#'
+#'     [protocol, push] The push protocol is one half of a pipeline pattern. The
+#'     other side is the pull protocol.
+#'
+#'     [protocol, pull] The pull protocol is one half of a pipeline pattern. The
+#'     other half is the push protocol.
+#'
 #' @section Publisher/Subscriber (topics & broadcast):
 #'
 #'     In a publisher/subscriber pattern, a publisher sends data, which is

R/messenger.R

@@ -19,9 +19,9 @@
 #'
 #'     \code{:q} is the command to quit.
 #'
-#'     NOTE: This is a proof of concept meant for use within friendly internal
+#'     NOTE: This is a proof of concept intended for use within internal
 #'     networks. Currently no measures are taken to verify the identity of
-#'     endpoints, hence should not be used to transmit sensitive information.
+#'     endpoints, and hence should not be used to transmit sensitive information.
 #'
 #' @export
 #'

R/nano.R

@@ -51,7 +51,7 @@
 #'
 #' @export
 #'
-nano <- function(protocol = c("pair", "bus", "push", "pull", "req", "rep",
+nano <- function(protocol = c("pair", "bus", "req", "rep", "push", "pull",
                               "pub", "sub", "surveyor", "respondent"),
                  dial = NULL,
                  listen = NULL,

R/nanonext-package.R

@@ -12,8 +12,7 @@
 #' @section Usage notes:
 #'
 #'     Call \code{\link{nano_init}} after package load to set global options.
-#'     The default by calling \code{nano_init()} with no arguments will cause
-#'     generated warnings to print immediately as they occur.
+#'     Using defaults will cause warnings to print immediately as they occur.
 #'
 #'     \{nanonext\} offers 2 equivalent interfaces: an object-oriented interface,
 #'     and a functional interface.

R/sendrecv.R

@@ -74,7 +74,7 @@ send.nanoSocket <- function(con,
                             block = FALSE,
                             echo = TRUE) {
 
-  mode <- match.arg(mode)
+  mode <- match.arg2(mode, c("serial", "raw"))
   force(data)
   data <- encode(data = data, mode = mode)
   res <- .Call(rnng_send, con, data, block)
@@ -93,7 +93,7 @@ send.nanoContext <- function(con,
                              block = TRUE,
                              echo = TRUE) {
 
-  mode <- match.arg(mode)
+  mode <- match.arg2(mode, c("serial", "raw"))
   if (missing(block) || isTRUE(block)) block <- -2L
   force(data)
   data <- encode(data = data, mode = mode)
@@ -114,7 +114,7 @@ send.nanoStream <- function(con,
                             echo = TRUE) {
 
   force(data)
-  data <- encode(data = data, mode = "raw")
+  data <- encode(data = data, mode = 2L)
   if (missing(block) || isTRUE(block)) block <- -2L
   res <- .Call(rnng_stream_send, con, data, block)
   is.integer(res) && return(invisible(res))
@@ -225,7 +225,8 @@ recv.nanoSocket <- function(con,
                             keep.raw = TRUE,
                             ...) {
 
-  mode <- match.arg(mode)
+  mode <- match.arg2(mode, c("serial", "character", "complex", "double",
+                             "integer", "logical", "numeric", "raw"))
   res <- .Call(rnng_recv, con, block)
   is.integer(res) && return(invisible(res))
   on.exit(expr = return(res))
@@ -246,7 +247,8 @@ recv.nanoContext <- function(con,
                              keep.raw = TRUE,
                              ...) {
 
-  mode <- match.arg(mode)
+  mode <- match.arg2(mode, c("serial", "character", "complex", "double",
+                             "integer", "logical", "numeric", "raw"))
   if (missing(block) || isTRUE(block)) block <- -2L
   res <- .Call(rnng_ctx_recv, con, block)
   is.integer(res) && return(invisible(res))
@@ -270,7 +272,8 @@ recv.nanoStream <- function(con,
                             n = 10000,
                             ...) {
 
-  mode <- match.arg(mode)
+  mode <- match.arg2(mode, c("character", "complex", "double", "integer",
+                             "logical", "numeric", "raw")) + 1L
   if (missing(block) || isTRUE(block)) block <- -2L
   res <- .Call(rnng_stream_recv, con, n, block)
   is.integer(res) && return(invisible(res))

R/socket.R

@@ -6,8 +6,8 @@
 #'     outgoing connection) or listen (accept an incoming connection) at an
 #'     address.
 #'
-#' @param protocol [default 'pair'] choose protocol - 'pair', 'bus', 'push',
-#'     'pull', 'req', 'rep', 'pub', 'sub', 'surveyor', or 'respondent' - see
+#' @param protocol [default 'pair'] choose protocol - 'pair', 'bus', 'req',
+#'     'rep', 'push', 'pull', 'pub', 'sub', 'surveyor', or 'respondent' - see
 #'     \link{protocols}.
 #' @param dial (optional) a URL to dial, specifying the transport and address as
 #'     a character string e.g. 'inproc://anyvalue' or 'tcp://127.0.0.1:5555'
@@ -57,25 +57,22 @@
 #'
 #' @export
 #'
-socket <- function(protocol = c("pair", "bus", "push", "pull", "req", "rep",
+socket <- function(protocol = c("pair", "bus", "req", "rep", "push", "pull",
                                 "pub", "sub", "surveyor", "respondent"),
                    dial = NULL,
                    listen = NULL,
                    autostart = TRUE) {
 
-  protocol <- match.arg(protocol)
+  protocol <- match.arg2(protocol, c("pair", "bus", "req", "rep", "push", "pull",
+                                     "pub", "sub", "surveyor", "respondent"))
   res <- .Call(rnng_protocol_open, protocol)
   is.integer(res) && return(invisible(res))
   if (.logging.) {
     loginfo(evt = "sock open", pkey = "id", pval = attr(res, "id"),
             skey = "protocol", sval = attr(res, "protocol"))
   }
-  if (!missing(dial)) {
-    dial(res, url = dial, autostart = autostart)
-  }
-  if (!missing(listen)) {
-    listen(res, url = listen, autostart = autostart)
-  }
+  if (!missing(dial)) dial(res, url = dial, autostart = autostart)
+  if (!missing(listen)) listen(res, url = listen, autostart = autostart)
   res
 
 }

R/utils.R

@@ -132,7 +132,7 @@ is_nul_byte <- function(x) identical(x, as.raw(0L))
 #'
 is_error_value <- function(x) inherits(x, "errorValue")
 
-#' Nanonext Initialise
+#' nanonext Initialise
 #'
 #' Initialise global options - intended to be called immediately after package load.
 #'
@@ -176,10 +176,8 @@ is_error_value <- function(x) inherits(x, "errorValue")
 #'
 nano_init <- function(warn = c("immediate", "deferred", "error", "none")) {
 
-  cand <- c("immediate", "deferred", "error", "none")
-  warn <- switch(pmatch(warn[1L], cand, nomatch = NULL),
-                 1L, 0L, 2L, -1L)
-  is.null(warn) && stop("'warn' should be one of ", paste(cand, collapse = ", "))
+  warn <- match.arg2(warn, c("immediate", "deferred", "error", "none"))
+  warn <- switch(warn, 1L, 0L, 2L, -1L)
   if (is.null(getOption("nanonext.original.warn"))) options(nanonext.original.warn = getOption("warn"))
   options(warn = warn)
   invisible(warn)
@@ -227,16 +225,27 @@ logging <- function(level = c("keep", "check", "error", "info")) {
 
 encode <- function(data, mode) {
   switch(mode,
-         serial = serialize(object = data, connection = NULL),
-         raw = if (is.raw(data)) data else writeBin(object = data, con = raw()))
+         serialize(object = data, connection = NULL),
+         if (is.raw(data)) data else writeBin(object = data, con = raw()))
 }
 
 decode <- function(con, mode) {
   switch(mode,
-         serial = unserialize(connection = con),
-         character = (r <- readBin(con = con, what = mode, n = length(con)))[r != ""],
-         raw = con,
-         readBin(con = con, what = mode, n = length(con)))
+         unserialize(connection = con),
+         (r <- readBin(con = con, what = "character", n = length(con)))[r != ""],
+         readBin(con = con, what = "complex", n = length(con)),
+         readBin(con = con, what = "double", n = length(con)),
+         readBin(con = con, what = "integer", n = length(con)),
+         readBin(con = con, what = "logical", n = length(con)),
+         readBin(con = con, what = "numeric", n = length(con)),
+         con)
+}
+
+match.arg2 <- function(choice, choices) {
+  arg <- deparse(substitute(choice))
+  index <- pmatch(choice[1L], choices, nomatch = 0L)
+  index || stop(sprintf("'%s' should be one of %s", arg, paste(choices, collapse = ", ")))
+  index
 }
 
 loginfo <- function(evt, pkey, pval, skey, sval) {