1
extensionToIMT <- function(filename, ext=NULL, default=NA) {
2 1
  if (is.null(ext)) {
3
    # If URI, drop any URI arguments
4 1
    if (isUrl(filename)) {
5 0
      filename <- splitUrl(filename)$path
6
    }
7 1
    ext <- gsub(".*[.]([^.]+)$", "\\1", filename)
8
  }
9 1
  ext <- tolower(ext)
10 1
  type <- switch(ext,
11 1
    "asciidoc" = "application/x-asciidoc",
12 1
    "atom"     = "application/atom+xml",
13 1
    "brew"     = "application/x-brew",
14 1
    "css"      = "text/css",
15 1
    "csv"      = "text/csv",
16 1
    "deb"      = "application/x-deb",
17 1
    "dtd"      = "application/xml-dtd",
18 1
    "htm"      = "text/html",
19 1
    "html"     = "text/html",
20 1
    "js"       = "application/javascript",
21 1
    "json"     = "application/json",
22 1
    "kml"      = "application/vnd.google-earth.kml+xml",
23 1
    "ltx"      = "application/x-latex", # To allow static LaTeX vignettes
24 1
    "md"       = "application/x-markdown",
25 1
    "pdf"      = "application/pdf",
26 1
    "ps"       = "application/postscript",
27 1
    "r"        = "application/R",
28 1
    "rdf"      = "application/rdf+xml",
29 1
    "rhtml"    = "application/x-rhtml",
30 1
    "rmd"      = "application/x-rmd",
31 1
    "rnw"      = "application/x-rnw",
32 1
    "rrst"     = "application/x-rrst",
33 1
    "rsp"      = "application/x-rsp",
34 1
    "rss"      = "application/rss+xml",
35 1
    "rtex"     = "application/x-rtex",
36 1
    "svg"      = "image/svg+xml",
37 1
    "tex"      = "application/x-latex",
38 1
    "txt"      = "text/plain",
39 1
    "vcard"    = "text/vcard",
40 1
    "vcf"      = "text/vcard",
41 1
    "vrml"     = "model/vrml",
42 1
    "xhtml"    = "application/xhtml+xml",
43 1
    "xml"      = "text/xml",  # also "application/xml"
44 1
    "xul"      = "application/application/vnd.mozilla.xul+xml",
45 1
    default
46
  )
47 1
  type
48
} # extensionToIMT()
49

50

51
escapeRspTags <- function(s) {
52 1
  s <- gsub(.rspBracketOpen,  .rspBracketOpenEscape,  s, fixed=TRUE)
53 1
  s <- gsub(.rspBracketClose, .rspBracketCloseEscape, s, fixed=TRUE)
54 1
  s
55
} # escapeRspTags()
56

57
unescapeRspTags <- function(s) {
58 1
  s <- gsub(.rspBracketOpenEscape,  .rspBracketOpen,  s, fixed=TRUE)
59 1
  s <- gsub(.rspBracketCloseEscape, .rspBracketClose, s, fixed=TRUE)
60 1
  s
61
} # unescapeRspTags()
62

63
escapeRspContent <- function(s, srcCT, targetCT, verbose=FALSE) {
64 0
  ct <- list(src=srcCT, target=targetCT)
65

66 0
  if (!is.list(ct$src)) {
67 0
    ct$src <- parseInternetMediaType(ct$src)
68
  }
69 0
  if (!is.list(ct$target)) {
70 0
    ct$target <- parseInternetMediaType(ct$target)
71
  }
72

73

74
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
75
  # (1a) Validate the source content type
76
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
77 0
  knownSourceTypes <- c("text/plain", "application/x-rsp", "application/x-latex", "application/x-tex")
78 0
  if (!is.element(ct$src$contentType, knownSourceTypes)) {
79 0
    msg <- sprintf("Source content type '%s' is unknown.  Will use 'text/plain' for escaping.", ct$src$contentType)
80 0
    warning(msg)
81 0
    verbose && cat(verbose, msg)
82 0
    ct$src <- parseInternetMediaType("text/plain")
83
  }
84

85
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
86
  # (1b) Validate the target content type
87
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
88 0
  knownTargetTypes <- c("text/plain", "application/x-latex", "application/x-tex")
89 0
  if (!is.element(ct$target$contentType, knownTargetTypes)) {
90 0
    msg <- sprintf("Target content type '%s' is unknown.  Will use 'text/plain' for escaping.", ct$target$contentType)
91 0
    warning(msg)
92 0
    verbose && cat(verbose, msg)
93 0
    ct$target <- parseInternetMediaType("text/plain")
94
  }
95

96

97
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
98
  # (2) "Merge" content types with the same escape rules
99
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
100 0
  for (key in names(ct)) {
101 0
    type <- ct[[key]]$contentType
102 0
    type <- sub("application/x-latex", "application/x-tex", type)
103 0
    ct[[key]]$contentType <- type
104
  }
105

106

107

108
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
109
  # (3) Escape text from source to target content type
110
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
111 0
  srcArgs <- ct$src$args
112 0
  srcArgsS <- paste(paste(names(srcArgs), srcArgs, sep="="), collapse=" ")
113 0
  targetArgs <- ct$target$args
114 0
  targetArgsS <- paste(paste(names(targetArgs), targetArgs, sep="="), collapse=" ")
115

116 0
  verbose && printf(verbose, "Translating content of type '%s' (%s) into type '%s' (%s).\n", ct$src$contentType, srcArgsS, ct$target$contentType, targetArgsS)
117

118

119
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
120
  # 'text/plain' -> ...
121
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
122 0
  if (ct$src$contentType == "text/plain") {
123 0
    if (ct$target$contentType == "text/plain") {
124 0
      s <- escapeRspTags(s)
125 0
    } else if (ct$target$contentType == "application/x-tex") {
126 0
      env <- ct$src$args["environment"]
127 0
      if (is.null(env) || is.na(env)) env <- ""
128 0
      env <- unlist(strsplit(env, split=",", fixed=TRUE), use.names=FALSE)
129 0
      env <- trim(env)
130 0
      if (is.element("math", env)) {
131
      }
132 0
      replace <- c("\\"="\\textbackslash", "{"="\\{", "}"="\\}",
133
                   "&"="\\&", "%"="\\%", "$"="\\$", "#"="\\#",
134
                   "_"="\\_",
135
                   "~"="\\~{}", "^"="\\^{}");  # <== ?
136 0
      search <- names(replace)
137 0
      for (ii in seq_along(replace)) {
138 0
        s <- gsub(search[ii], replace[ii], s, fixed=TRUE)
139
      }
140
    }
141
  }
142

143
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
144
  # 'application/x-rsp' -> ...
145
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
146 0
  if (ct$src$contentType == "application/x-rsp") {
147 0
    escaped <- identical(unname(ct$src$args["escaped"]), "TRUE")
148 0
    if (escaped) {
149 0
      s <- unescapeRspTags(s)
150
    }
151 0
    if (ct$target$contentType == "text/plain") {
152 0
    } else if (ct$target$contentType == "application/x-tex") {
153
    }
154
  }
155

156 0
  as.character(s)
157
} # escapeRspContent()
158

159

160
# \references{
161
#   [1] \emph{Internet Media Type},
162
#       \url{https://www.wikipedia.org/wiki/Internet_media_type}
163
# }
164
parseInternetMediaType <- function(s, ...) {
165
  # Nothing to do?
166 1
  if (is.na(s)) {
167 0
    return(s)
168
  }
169

170
  # Example e.g. "text/html; charset=UTF-8"
171 1
  s <- trim(s)
172 1
  pattern <- "^([^/]*)/([^;]*)(|;[ ]*(.*))$"
173 1
  if (regexpr(pattern, s) == -1L) {
174 0
    throw("Syntax error: Not an internet media type: ", sQuote(s))
175
  }
176

177
  # Extract: <type>/<subtype>
178 1
  type <- gsub(pattern, "\\1", s)
179 1
  subtype <- gsub(pattern, "\\2", s)
180

181
  # Extract: <name>=<value>*
182 1
  argsS <- gsub(pattern, "\\4", s)
183 1
  patternS <- "^([^=]*)=([^ ]*)(.*)"
184 1
  args <- NULL
185 1
  while(nchar(argsS <- trim(argsS)) > 0L) {
186 0
    if (regexpr(patternS, argsS) == -1L) {
187 0
      throw("Syntax error: Invalid internet media type argument: ", sQuote(argsS))
188
    }
189 0
    name <- gsub(patternS, "\\1", argsS)
190 0
    value <- gsub(patternS, "\\2", argsS)
191 0
    names(value) <- name
192 0
    args <- c(args, value)
193 0
    argsS <- gsub(patternS, "\\3", argsS)
194
  }
195

196 1
  list(
197 1
    contentType=sprintf("%s/%s", type, subtype),
198 1
    type=type,
199 1
    subtype=subtype,
200 1
    args=args
201
  )
202
} # parseInternetMediaType()

Read our documentation on viewing source code .

Loading