1

2
# TODO: delete once we require R 3.3.0
3
trimws <- function(string){
4 1
  string <- gsub("^\\s+", "", string)
5 1
  gsub("\\s+$", "", string)
6
}
7

8
stopOnLine <- function(lineNum, line, msg){
9 1
  stop("Error on line #", lineNum, ": '", line, "' - ", msg)
10
}
11

12
#' @param lineNum The line number just above the function we're documenting
13
#' @param file A character vector representing all the lines in the file
14
#' @param envir An environment where to evaluate parsed expressions
15
#' @noRd
16
plumbBlock <- function(lineNum, file, envir = parent.frame()){
17 1
  paths <- NULL
18 1
  preempt <- NULL
19 1
  filter <- NULL
20 1
  serializer <- NULL
21 1
  parsers <- NULL
22 1
  assets <- NULL
23 1
  params <- NULL
24 1
  comments <- ""
25 1
  responses <- NULL
26 1
  tags <- NULL
27 1
  routerModifier <- NULL
28 1
  while (lineNum > 0 && (stri_detect_regex(file[lineNum], pattern="^#['\\*]") || stri_trim_both(file[lineNum]) == "")){
29

30 1
    line <- file[lineNum]
31

32 1
    epMat <- stri_match(line, regex="^#['\\*]\\s*@(get|put|post|use|delete|head|options|patch)(\\s+(.*)$)?")
33 1
    if (!is.na(epMat[1,2])){
34 1
      p <- stri_trim_both(epMat[1,4])
35

36 1
      if (is.na(p) || p == ""){
37 1
        stopOnLine(lineNum, line, "No path specified.")
38
      }
39

40 1
      if (is.null(paths)){
41 1
        paths <- list()
42
      }
43

44 1
      paths[[length(paths)+1]] <- list(verb = enumerateVerbs(epMat[1,2]), path = p)
45
    }
46

47 1
    filterMat <- stri_match(line, regex="^#['\\*]\\s*@filter(\\s+(.*)$)?")
48 1
    if (!is.na(filterMat[1,1])){
49 1
      f <- stri_trim_both(filterMat[1,3])
50

51 1
      if (is.na(f) || f == ""){
52 1
        stopOnLine(lineNum, line, "No @filter name specified.")
53
      }
54

55 1
      if (!is.null(filter)){
56
        # Must have already assigned.
57 1
        stopOnLine(lineNum, line, "Multiple @filters specified for one function.")
58
      }
59

60 1
      filter <- f
61
    }
62

63 1
    preemptMat <- stri_match(line, regex="^#['\\*]\\s*@preempt(\\s+(.*)\\s*$)?")
64 1
    if (!is.na(preemptMat[1,1])){
65 1
      p <- stri_trim_both(preemptMat[1,3])
66 1
      if (is.na(p) || p == ""){
67 1
        stopOnLine(lineNum, line, "No @preempt specified")
68
      }
69 1
      if (!is.null(preempt)){
70
        # Must have already assigned.
71 1
        stopOnLine(lineNum, line, "Multiple @preempts specified for one function.")
72
      }
73 1
      preempt <- p
74
    }
75

76 1
    assetsMat <- stri_match(line, regex="^#['\\*]\\s*@assets(\\s+(\\S*)(\\s+(\\S+))?\\s*)?$")
77 1
    if (!is.na(assetsMat[1,1])){
78 1
      dir <- stri_trim_both(assetsMat[1,3])
79 1
      if (is.na(dir) || dir == ""){
80 1
        stopOnLine(lineNum, line, "No directory specified for @assets")
81
      }
82 1
      prefixPath <- stri_trim_both(assetsMat[1,5])
83 1
      if (is.na(prefixPath) || prefixPath == ""){
84 1
        prefixPath <- "/public"
85
      }
86 1
      if (!is.null(assets)){
87
        # Must have already assigned.
88 0
        stopOnLine(lineNum, line, "Multiple @assets specified for one entity.")
89
      }
90 1
      assets <- list(dir=dir, path=prefixPath)
91
    }
92

93 1
    serMat <- stri_match(line, regex="^#['\\*]\\s*@serializer(\\s+([^\\s]+)\\s*(.*)\\s*$)?")
94 1
    if (!is.na(serMat[1,1])){
95 1
      s <- stri_trim_both(serMat[1,3])
96 1
      if (is.na(s) || s == ""){
97 1
        stopOnLine(lineNum, line, "No @serializer specified")
98
      }
99 1
      if (!is.null(serializer)){
100
        # Must have already assigned.
101 1
        stopOnLine(lineNum, line, "Multiple @serializers specified for one function.")
102
      }
103

104 1
      if (!(s %in% registered_serializers())){
105 1
        stopOnLine(lineNum, line, paste0("No such @serializer registered: ", s))
106
      }
107

108 1
      ser <- get_registered_serializer(s)
109

110 1
      if (!is.na(serMat[1, 4]) && serMat[1,4] != ""){
111
        # We have an arg to pass in to the serializer
112 1
        argList <- tryCatch({
113 1
          eval(parse(text=serMat[1,4]), envir)
114 1
        }, error = function(e) {
115 0
          stopOnLine(lineNum, line, e)
116
        })
117
      } else {
118 1
        argList <- list()
119
      }
120 1
      tryCatch({
121 1
        serializer <- do.call(ser, argList)
122 1
      }, error = function(e) {
123 0
        stopOnLine(lineNum, line, paste0("Error creating serializer: ", s, "\n", e))
124
      })
125

126
    }
127

128 1
    shortSerMat <- stri_match(line, regex="^#['\\*]\\s*@(json|html|jpeg|png|svg)(.*)$")
129 1
    if (!is.na(shortSerMat[1,2])) {
130 1
      s <- stri_trim_both(shortSerMat[1,2])
131 1
      .Deprecated(msg = paste0(
132 1
        "Plumber tag `#* @", s, "` is deprecated.\n",
133 1
        "Use `#* @serializer ", s, "` instead."
134
      ))
135 1
      if (!is.null(serializer)){
136
        # Must have already assigned.
137 0
        stopOnLine(lineNum, line, "Multiple @serializers specified for one function (shorthand serializers like @json count, too).")
138
      }
139

140 1
      if (!is.na(s) && !(s %in% registered_serializers())){
141 0
        stopOnLine(lineNum, line, paste0("No such @serializer registered: ", s))
142
      }
143 1
      shortSerAttr <- trimws(shortSerMat[1,3])
144 1
      if(!identical(shortSerAttr, "") && !grepl("^\\(.*\\)$", shortSerAttr)){
145 1
        stopOnLine(lineNum, line, paste0("Supplemental arguments to the serializer must be surrounded by parentheses, as in `#' @", s, "(na='null')`"))
146
      }
147

148 1
      if (shortSerAttr != "") {
149
        # We have an arg to pass in to the serializer
150 1
        argList <- tryCatch({
151 1
          eval(parse(text=paste0("list", shortSerAttr)), envir)
152 1
        }, error = function(e) {
153 0
          stopOnLine(lineNum, line, e)
154
        })
155
      } else {
156 1
        argList <- list()
157
      }
158 1
      tryCatch({
159 1
        serializer <- do.call(get_registered_serializer(s), argList)
160 1
      }, error = function(e) {
161 0
        stopOnLine(lineNum, line, paste0("Error creating serializer: ", s, "\n", e))
162
      })
163
    }
164

165 1
    parsersMat <- stri_match(line, regex="^#['\\*]\\s*@parser(\\s+([^\\s]+)\\s*(.*)\\s*$)?")
166 1
    if (!is.na(parsersMat[1,1])){
167 1
      parser_alias <- stri_trim_both(parsersMat[1,3])
168 1
      if (is.na(parser_alias) || parser_alias == ""){
169 0
        stopOnLine(lineNum, line, "No @parser specified")
170
      }
171

172 1
      if (!parser_alias %in% registered_parsers()){
173 0
        stopOnLine(lineNum, line, paste0("No such @parser registered: ", parser_alias))
174
      }
175

176 1
      if (!is.na(parsersMat[1, 4]) && parsersMat[1,4] != ""){
177
        # We have an arg to pass in to the parser
178 0
        arg_list <- tryCatch({
179 0
          eval(parse(text=parsersMat[1,4]), envir)
180 0
        }, error = function(e) {
181 0
          stopOnLine(lineNum, line, e)
182
        })
183
      } else {
184 1
        arg_list <- list()
185
      }
186 1
      if (is.null(parsers)) {
187 1
        parsers <- list()
188
      }
189 1
      parsers[[parser_alias]] <- arg_list
190
    }
191

192 1
    responseMat <- stri_match(line, regex="^#['\\*]\\s*@response\\s+(\\w+)\\s+(\\S.+)\\s*$")
193 1
    if (!is.na(responseMat[1,1])){
194 1
      resp <- list()
195 1
      resp[[responseMat[1,2]]] <- list(description=responseMat[1,3])
196 1
      responses <- c(responses, resp)
197
    }
198

199 1
    paramMat <- stri_match(line, regex="^#['\\*]\\s*@param(\\s+([^\\s:]+):?([^\\s*]+)?(\\*)?(?:\\s+(.*))?\\s*$)?")
200 1
    if (!is.na(paramMat[1,2])){
201 1
      name <- paramMat[1,3]
202 1
      if (is.na(name)){
203 0
        stopOnLine(lineNum, line, "No parameter specified.")
204
      }
205 1
      plumberType <- stri_replace_all(paramMat[1,4], "$1", regex = "^\\[([^\\]]*)\\]$")
206 1
      apiType <- plumberToApiType(plumberType)
207 1
      isArray <- stri_detect_regex(paramMat[1,4], "^\\[[^\\]]*\\]$")
208 1
      isArray[is.na(isArray)] <- defaultIsArray
209 1
      required <- identical(paramMat[1,5], "*")
210

211 1
      params[[name]] <- list(desc=paramMat[1,6], type=apiType, required=required, isArray=isArray)
212
    }
213

214 1
    tagMat <- stri_match(line, regex="^#['\\*]\\s*@tag\\s+(\\S.+)\\s*")
215 1
    if (!is.na(tagMat[1,1])){
216 1
      t <- stri_trim_both(tagMat[1,2])
217 1
      if (is.na(t) || t == ""){
218 0
        stopOnLine(lineNum, line, "No tag specified.")
219
      }
220 1
      if (t %in% tags){
221 1
        stopOnLine(lineNum, line, "Duplicate tag specified.")
222
      }
223 1
      tags <- c(tags, t)
224
    }
225

226 1
    commentMat <- stri_match(line, regex="^#['\\*]\\s*([^@\\s].*$)")
227 1
    if (!is.na(commentMat[1,2])){
228 1
      comments <- paste(comments, commentMat[1,2])
229
    }
230

231 1
    routerModifierMat <- stri_match(line, regex="^#['\\*]\\s*@plumber")
232 1
    if (!is.na(routerModifierMat[1,1])) {
233 1
      routerModifier <- TRUE
234
    }
235

236 1
    lineNum <- lineNum - 1
237
  }
238

239 1
  list(
240 1
    paths = paths,
241 1
    preempt = preempt,
242 1
    filter = filter,
243 1
    serializer = serializer,
244 1
    parsers = parsers,
245 1
    assets = assets,
246 1
    params = rev(params),
247 1
    comments = comments,
248 1
    responses = responses,
249 1
    tags = tags,
250 1
    routerModifier = routerModifier
251
  )
252
}
253

254
#' Evaluate and activate a "block" of code found in a plumber API file.
255
#' @noRd
256
evaluateBlock <- function(srcref, file, expr, envir, addEndpoint, addFilter, pr) {
257 1
  lineNum <- srcref[1] - 1
258

259 1
  block <- plumbBlock(lineNum, file, envir)
260

261 1
  if (sum(!is.null(block$filter), !is.null(block$paths), !is.null(block$assets), !is.null(block$routerModifier)) > 1){
262 1
    stopOnLine(lineNum, file[lineNum], "A single function can only be a filter, an API endpoint, an asset or a Plumber object modifier (@filter AND @get, @post, @assets, @plumber, etc.)")
263
  }
264

265
  # ALL if statements possibilities must eventually call eval(expr, envir)
266 1
  if (!is.null(block$paths)){
267 1
    lapply(block$paths, function(p) {
268 1
      ep <- PlumberEndpoint$new(
269 1
        verbs = p$verb,
270 1
        path = p$path,
271 1
        expr = expr,
272 1
        envir = envir,
273 1
        serializer = block$serializer,
274 1
        parsers = block$parsers,
275 1
        lines = srcref,
276 1
        params = block$params,
277 1
        comments = block$comments,
278 1
        responses = block$responses,
279 1
        tags = block$tags
280
      )
281

282 1
      addEndpoint(ep, block$preempt)
283
    })
284 1
  } else if (!is.null(block$filter)){
285 1
    filter <- PlumberFilter$new(block$filter, expr, envir, block$serializer, srcref)
286 1
    addFilter(filter)
287

288 1
  } else if (!is.null(block$assets)){
289 1
    path <- block$assets$path
290

291
    # Leading slash
292 1
    if (substr(path, 1,1) != "/"){
293 1
      path <- paste0("/", path)
294
    }
295

296 1
    stat <- PlumberStatic$new(block$assets$dir, expr)
297 1
    pr$mount(path, stat)
298

299 1
  } else if (!is.null(block$routerModifier)) {
300 1
    if (is.expression(expr)){
301 1
      func <- tryCatch({
302 1
        eval(expr, envir)
303 1
      }, error = function(e) {
304 0
        stopOnLine(lineNum, file[lineNum], e)
305
      })
306 1
      if (is.function(func)) {
307 1
        assign(".__plump_block_check__", TRUE, envir = envir)
308 1
        on.exit(rm(".__plump_block_check__", envir = envir), add = TRUE)
309 1
        fpr <- func(pr)
310 1
        if (inherits(fpr, "Plumber") && !isTRUE(fpr$environment[[".__plump_block_check__"]])) {
311 0
          stopOnLine(lineNum, file[lineNum], "Plumber object returned is not the same as the one in argument.")
312
        }
313 1
        return()
314
      }
315
    }
316 0
    stopOnLine(lineNum, file[lineNum], "Invalid expression for @plumber tag, please use the form `function(pr) { }`.")
317
  } else {
318 1
    tryCatch({
319 1
      eval(expr, envir)
320 1
    }, error = function(e) {
321 0
      stopOnLine(lineNum, file[lineNum], e)
322
    })
323
  }
324
}

Read our documentation on viewing source code .

Loading