-
Notifications
You must be signed in to change notification settings - Fork 84
/
git.R
184 lines (146 loc) · 4.94 KB
/
git.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
# unexported fns from devtools, we include them here so
# we don't have to use :::
# from https://github.com/hadley/devtools/blob/master/R/git.R
uses_git <- function(path = ".") {
!is.null(git2r::discover_repository(path, ceiling = 0))
}
# sha of most recent commit
git_repo_sha1 <- function(r) {
rev <- git2r::head(r)
if (is.null(rev)) {
return(NULL)
}
if (git2r::is_commit(rev)) {
rev@sha
} else {
git2r::branch_target(rev)
}
}
git_sha1 <- function(n = 10, path = ".") {
r <- git2r::repository(path, discover = TRUE)
sha <- git_repo_sha1(r)
substr(sha, 1, n)
}
git_uncommitted <- function(path = ".") {
r <- git2r::repository(path, discover = TRUE)
st <- vapply(git2r::status(r), length, integer(1))
any(st != 0)
}
git_sync_status <- function(path = ".", check_ahead = TRUE, check_behind = TRUE) {
r <- git2r::repository(path, discover = TRUE)
r_head <- git2r::head(r)
if (!methods::is(r_head, "git_branch")) {
stop("HEAD is not a branch", call. = FALSE)
}
upstream <- git2r::branch_get_upstream(r_head)
if (is.null(upstream)) {
stop("No upstream branch", call. = FALSE)
}
git2r::fetch(r, git2r::branch_remote_name(upstream))
c1 <- git2r::lookup(r, git2r::branch_target(r_head))
c2 <- git2r::lookup(r, git2r::branch_target(upstream))
ab <- git2r::ahead_behind(c1, c2)
# if (ab[1] > 0)
# message(ab[1], " ahead of remote")
# if (ab[2] > 0)
# message(ab[2], " behind remote")
is_ahead <- ab[[1]] != 0
is_behind <- ab[[2]] != 0
check <- (check_ahead && is_ahead) || (check_behind && is_behind)
check
}
# Retrieve the current running path of the git binary.
# @param git_binary_name The name of the binary depending on the OS.
git_path <- function(git_binary_name = NULL) {
# Use user supplied path
if (!is.null(git_binary_name)) {
if (!file.exists(git_binary_name)) {
stop("Path ", git_binary_name, " does not exist", .call = FALSE)
}
return(git_binary_name)
}
# Look on path
git_path <- Sys.which("git")[[1]]
if (git_path != "") return(git_path)
# On Windows, look in common locations
if (.Platform$OS.type == "windows") {
look_in <- c(
"C:/Program Files/Git/bin/git.exe",
"C:/Program Files (x86)/Git/bin/git.exe"
)
found <- file.exists(look_in)
if (any(found)) return(look_in[found][1])
}
stop("Git does not seem to be installed on your system.", call. = FALSE)
}
git_branch <- function(path = ".") {
r <- git2r::repository(path, discover = TRUE)
if (git2r::is_detached(r)) {
return(NULL)
}
git2r::head(r)@name
}
# GitHub ------------------------------------------------------------------
uses_github <- function(path = ".") {
if (!uses_git(path))
return(FALSE)
r <- git2r::repository(path, discover = TRUE)
r_remote_urls <- git2r::remote_url(r)
any(grepl("github", r_remote_urls))
}
github_info <- function(path = ".", remote_name = NULL) {
if (!uses_github(path))
return(github_dummy)
r <- git2r::repository(path, discover = TRUE)
r_remote_urls <- grep("github", remote_urls(r), value = TRUE)
if (!is.null(remote_name) && !remote_name %in% names(r_remote_urls))
stop("no github-related remote named ", remote_name, " found")
remote_name <- c(remote_name, "origin", names(r_remote_urls))
x <- r_remote_urls[remote_name]
x <- x[!is.na(x)][1]
github_remote_parse(x)
}
github_dummy <- list(username = "<USERNAME>", repo = "<REPO>", fullname = "<USERNAME>/<REPO>")
remote_urls <- function(r) {
remotes <- git2r::remotes(r)
stats::setNames(git2r::remote_url(r, remotes), remotes)
}
github_remote_parse <- function(x) {
if (length(x) == 0) return(github_dummy)
if (!grepl("github", x)) return(github_dummy)
if (grepl("^(https|git)", x)) {
# https://github.com/hadley/devtools.git
# https://github.com/hadley/devtools
# git@github.com:hadley/devtools.git
re <- "github[^/:]*[/:]([^/]+)/(.*?)(?:\\.git)?$"
} else {
stop("Unknown GitHub repo format", call. = FALSE)
}
m <- regexec(re, x)
match <- regmatches(x, m)[[1]]
list(
username = match[2],
repo = match[3],
fullname = paste0(match[2], "/", match[3])
)
}
# Extract the commit hash from a git archive. Git archives include the SHA1
# hash as the comment field of the zip central directory record
# (see https://www.kernel.org/pub/software/scm/git/docs/git-archive.html)
# Since we know it's 40 characters long we seek that many bytes minus 2
# (to confirm the comment is exactly 40 bytes long)
git_extract_sha1 <- function(bundle) {
# open the bundle for reading
conn <- file(bundle, open = "rb", raw = TRUE)
on.exit(close(conn))
# seek to where the comment length field should be recorded
seek(conn, where = -0x2a, origin = "end")
# verify the comment is length 0x28
len <- readBin(conn, "raw", n = 2)
if (len[1] == 0x28 && len[2] == 0x00) {
# read and return the SHA1
rawToChar(readBin(conn, "raw", n = 0x28))
} else {
NULL
}
}