1# Copyright (C) 2021 Brodie Gaslam
2#
3# This file is part of "diffobj - Diffs for R Objects"
4#
5# This program is free software: you can redistribute it and/or modify
6# it under the terms of the GNU General Public License as published by
7# the Free Software Foundation, either version 2 of the License, or
8# (at your option) any later version.
9#
10# This program is distributed in the hope that it will be useful,
11# but WITHOUT ANY WARRANTY; without even the implied warranty of
12# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13# GNU General Public License for more details.
14#
15# Go to <https://www.r-project.org/Licenses/GPL-2> for a copy of the license.
16
17#' Run Rdiff Directly on R Objects
18#'
19#' These functions are here for reference and testing purposes.  They are
20#' wrappers to \code{tools::Rdiff} and rely on an existing system diff utility.
21#' You should be using \code{\link{ses}} or \code{\link{diffChr}} instead of
22#' \code{Rdiff_chr} and \code{\link{diffPrint}} instead of \code{Rdiff_obj}.
23#' See limitations in note.
24#'
25#' \code{Rdiff_chr} runs diffs on character vectors or objects coerced to
26#' character vectors, where each value in the vectors is treated as a line in a
27#' file.  \code{Rdiff_chr} always runs with the \code{useDiff} and \code{Log}
28#' parameters set to \code{TRUE}.
29#'
30#' \code{Rdiff_obj} runs diffs on the \code{print}ed representation of
31#' the provided objects.  For each of \code{from}, \code{to}, will check if they
32#' are 1 length character vectors referencing an RDS file, and will use the
33#' contents of that RDS file as the object to compare.
34#'
35#' @note These functions will try to use the system \code{diff} utility. This
36#'   will fail in systems that do not have that utility available (e.g. windows
37#'   installation without Rtools).
38#' @importFrom tools Rdiff
39#' @export
40#' @seealso \code{\link{ses}}, \code{\link[=diffPrint]{diff*}}
41#' @param from character or object coercible to character for \code{Rdiff_chr},
42#'   any R object with \code{Rdiff_obj}, or a file pointing to an RDS object
43#' @param to character same as \code{from}
44#' @param nullPointers passed to \code{tools::Rdiff}
45#' @param silent TRUE or FALSE, whether to display output to screen
46#' @param minimal TRUE or FALSE, whether to exclude the lines that show the
47#'   actual differences or only the actual edit script commands
48#' @return the Rdiff output, invisibly if \code{silent} is FALSE
49#' Rdiff_chr(letters[1:5], LETTERS[1:5])
50#' Rdiff_obj(letters[1:5], LETTERS[1:5])
51
52Rdiff_chr <- function(from, to, silent=FALSE, minimal=FALSE, nullPointers=TRUE) {
53  A <- try(as.character(from))
54  if(inherits(A, "try-error")) stop("Unable to coerce `target` to character.")
55  B <- try(as.character(to))
56  if(inherits(B, "try-error")) stop("Unable to coerce `current` to character.")
57
58  af <- tempfile()
59  bf <- tempfile()
60  writeLines(A, af)
61  writeLines(B, bf)
62  on.exit(unlink(c(af, bf)))
63
64  Rdiff_run(
65    silent=silent, minimal=minimal, from=af, to=bf, nullPointers=nullPointers
66  )
67}
68#' @export
69#' @rdname Rdiff_chr
70
71Rdiff_obj <- function(from, to, silent=FALSE, minimal=FALSE, nullPointers=TRUE) {
72  dummy.env <- new.env()  # used b/c unique object
73  files <- try(
74    vapply(
75      list(from, to),
76      function(x) {
77        if(
78          is.character(x) && length(x) == 1L && !is.na(x) && file_test("-f", x)
79        ) {
80          rdstry <- tryCatch(readRDS(x), error=function(x) dummy.env)
81          if(!identical(rdstry, dummy.env)) x <- rdstry
82        }
83        f <- tempfile()
84        on.exit(unlink(f))
85        capture.output(if(isS4(x)) show(x) else print(x), file=f)
86        on.exit()
87        f
88      },
89      character(1L)
90  ) )
91  if(inherits(files, "try-error"))
92    stop("Unable to store text representation of objects")
93  on.exit(unlink(files))
94  Rdiff_run(
95    from=files[[1L]], to=files[[2L]], silent=silent, minimal=minimal,
96    nullPointers=nullPointers
97  )
98}
99# Internal use only: BEWARE, will unlink from, to
100
101Rdiff_run <- function(from, to, nullPointers, silent, minimal) {
102  stopifnot(
103    isTRUE(silent) || identical(silent, FALSE),
104    isTRUE(minimal) || identical(minimal, FALSE)
105  )
106  res <- tryCatch(
107    Rdiff(
108      from=from, to=to, useDiff=TRUE, Log=TRUE, nullPointers=nullPointers
109    )$out,
110    warning=function(e)
111      stop(
112        "`tools::Rdiff` returned a warning; this likely means you are running ",
113        "without a `diff` utility accessible to R"
114      )
115  )
116  if(!is.character(res))
117    # nocov start
118    stop("Internal Error: Unexpected tools::Rdiff output, contact maintainer")
119    # nocov end
120
121  res <- if(minimal) res[!grepl("^[<>-]", res)] else res
122  if(silent) res else {
123    cat(res, sep="\n")
124    invisible(res)
125  }
126}
127#' Attempt to Detect Whether diff Utility is Available
128#'
129#' Checks whether \code{\link[=Rdiff]{tools::Rdiff}} issues a warning when
130#' running with \code{useDiff=TRUE} and if it does assumes this is because the
131#' diff utility is not available.  Intended primarily for testing purposes.
132#'
133#' @export
134#' @return TRUE or FALSE
135#' @param test.with function to test for diff presence with, typically Rdiff
136#' @examples
137#' has_Rdiff()
138
139has_Rdiff <- function(test.with=tools::Rdiff) {
140  f.a <- tempfile()
141  f.b <- tempfile()
142  on.exit(unlink(c(f.a, f.b)))
143  writeLines(letters[1:3], f.a)
144  writeLines(LETTERS, f.b)
145  tryCatch(
146    {
147      test.with(
148        from=f.a, to=f.b, useDiff=TRUE, Log=TRUE, nullPointers=FALSE
149      )
150      TRUE
151    }, warning=function(e) FALSE
152  )
153}
154