suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add a branch indicator to the stamp, if we can find one and it's not "master".

Browse Source 
Added by Sam's request.
This commit is contained in:
Eli Barzilay 2012-05-04 20:18:20 -04:00
parent 6e1ee717f7
commit 1fae7942d5
1 changed files with 41 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

66
collects/repo-time-stamp/stamp.rkt
View File

@ -19,25 +19,28 @@
the expected value for nightly builds. the expected value for nightly builds.
* "g" -- `archive-id' didn't have information, but we found a git * "g" -- `archive-id' didn't have information, but we found a git
executable and ran it. executable and ran it. [*]
* "d" -- an executable was not found either, but a ".git" directory * "d" -- an executable was not found either, but a ".git" directory
was found in the usual place, with a "HEAD" file that has eventually was found in the usual place, with a "HEAD" file that has eventually
lead to a SHA1. In this case, the time stamp is the stamp of the lead to a SHA1. In this case, the time stamp is the stamp of the
git reference file that was used. git reference file that was used. [*]
* "f" -- none of the above worked, so the last resort was to report * "f" -- none of the above worked, so the last resort was to report
the date of this file (which can provide a rough idea how old the the date of this file (which can provide a rough idea how old the
tree is, but obviously this can be arbitrary). In this case the tree is, but obviously this can be arbitrary). In this case the
SHA1 is missing and will be "-". SHA1 is missing and will be "-".
[*] In case of "g"/"d", another part is added, indicating the branch
name if one was found and if it isn't "master"; Eg, ".../g/foo".
|# |#
(define archive-id "$Format:%ct|%h|a$") (define archive-id "$Format:%ct|%h|a$")
;; when exported through `git archive', the above becomes something like ;; when exported through `git archive', the above becomes something like
;; "1273562690|cabd414|a" ;; "1273562690|cabd414|a"
(require racket/system racket/runtime-path) (require racket/system racket/runtime-path racket/string)
(define-runtime-path this-dir ".") (define-runtime-path this-dir ".")
(define-runtime-path this-file "stamp.rkt") (define-runtime-path this-file "stamp.rkt")
@ -46,39 +49,52 @@
(let ([rx:secs+id #rx"^([0-9]+)\\|([0-9a-f]+|-)\\|(.*?)[ \r\n]*$"]) (let ([rx:secs+id #rx"^([0-9]+)\\|([0-9a-f]+|-)\\|(.*?)[ \r\n]*$"])
;; info from an archive (incl. nightly builds) ;; info from an archive (incl. nightly builds)
(define (from-archive-id) archive-id) (define (from-archive-id) archive-id)
;; adds a branch name if applicable (and if different from `master')
(define (add-branch str br*)
(define br
(and (string? br*)
(not (member br* '("refs/heads/master" "")))
(regexp-replace #rx"^refs/(?:heads/|remotes/)?" br* "")))
(if br (string-append str "/" br) str))
;; try to run git to get the current info ;; try to run git to get the current info
(define (from-running-git) (define (from-running-git)
(let ([exe (or (find-executable-path "git") (define exe
(find-executable-path "git.exe") (or (find-executable-path "git")
(and (eq? 'macosx (system-type)) (find-executable-path "git.exe")
(find-executable-path "/opt/local/bin/git")))]) (and (eq? 'macosx (system-type))
(and exe (let ([out (open-output-string)]) (find-executable-path "/opt/local/bin/git"))))
(parameterize ([current-output-port out] (define (git . args)
[current-error-port out] (define out (open-output-string))
[current-input-port (open-input-string "")] (parameterize ([current-output-port out]
[current-directory this-dir]) [current-error-port out]
(system* exe "log" "-1" "--pretty=format:%ct|%h|g") [current-input-port (open-input-string "")]
(get-output-string out)))))) [current-directory this-dir])
(apply system* exe args)
(string-trim (get-output-string out))))
(and exe (add-branch (git "log" "-1" "--pretty=format:%ct|%h|g")
(git "rev-parse" "--symbolic-full-name" "HEAD"))))
;; try to find a ".git" directory (can't run git, so conventional ;; try to find a ".git" directory (can't run git, so conventional
;; guess) and use the sha1 from that file and its date ;; guess) and use the sha1 from that file and its date
(define (from-git-dir) (define (from-git-dir)
(define git-dir (build-path this-dir 'up 'up ".git")) (define git-dir (build-path this-dir 'up 'up ".git"))
(define branch #f)
(let loop ([file (build-path git-dir "HEAD")]) (let loop ([file (build-path git-dir "HEAD")])
(let ([l (and (file-exists? file) (define l (and (file-exists? file)
(call-with-input-file file read-line))]) (call-with-input-file file read-line)))
(cond [(not l) #f] (cond [(not l) #f]
[(regexp-match #rx"^ref: +(.*)$" l) [(regexp-match #rx"^ref: +(.*)$" l)
=> (lambda (m) => (λ (m) (unless branch (set! branch (cadr m)))
(loop (build-path git-dir (cadr m))))] (loop (build-path git-dir (cadr m))))]
[(regexp-match #px"^[[:xdigit:]]{40}$" l) [(regexp-match #px"^[[:xdigit:]]{40}$" l)
(format "~a|~a|d" (add-branch (format "~a|~a|d"
(file-or-directory-modify-seconds file) (file-or-directory-modify-seconds file)
(substring l 0 8))])))) (substring l 0 8))
branch)])))
;; fallback: get the date of this file, no id ;; fallback: get the date of this file, no id
(define (from-this-file) (define (from-this-file)
(format "~a|-|f" (file-or-directory-modify-seconds this-file))) (format "~a|-|f" (file-or-directory-modify-seconds this-file)))
(for*/or ([x (list from-archive-id (for*/or ([x (list from-archive-id
from-running-git ;; from-running-git
from-git-dir from-git-dir
from-this-file)]) from-this-file)])
(let* ([x (x)] (let* ([x (x)]