From 1fae7942d583352306e6acb302f98b4639e7eca8 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@barzilay.org>
Date: Fri, 4 May 2012 20:18:20 -0400
Subject: [PATCH] Add a branch indicator to the stamp, if we can find one and
 it's not "master".

Added by Sam's request.
---
 collects/repo-time-stamp/stamp.rkt | 66 +++++++++++++++++++-----------
 1 file changed, 41 insertions(+), 25 deletions(-)

diff --git a/collects/repo-time-stamp/stamp.rkt b/collects/repo-time-stamp/stamp.rkt
index 63e70be139..d9df32f7a1 100644
--- a/collects/repo-time-stamp/stamp.rkt
+++ b/collects/repo-time-stamp/stamp.rkt
@@ -19,25 +19,28 @@
     the expected value for nightly builds.
 
   * "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
     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
-    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
     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
     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$")
 ;; when exported through `git archive', the above becomes something like
 ;; "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-file "stamp.rkt")
@@ -46,39 +49,52 @@
   (let ([rx:secs+id #rx"^([0-9]+)\\|([0-9a-f]+|-)\\|(.*?)[ \r\n]*$"])
     ;; info from an archive (incl. nightly builds)
     (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
     (define (from-running-git)
-      (let ([exe (or (find-executable-path "git")
-                     (find-executable-path "git.exe")
-                     (and (eq? 'macosx (system-type))
-                          (find-executable-path "/opt/local/bin/git")))])
-        (and exe (let ([out (open-output-string)])
-                   (parameterize ([current-output-port out]
-                                  [current-error-port out]
-				  [current-input-port (open-input-string "")]
-                                  [current-directory this-dir])
-                     (system* exe "log" "-1" "--pretty=format:%ct|%h|g")
-                     (get-output-string out))))))
+      (define exe
+        (or (find-executable-path "git")
+            (find-executable-path "git.exe")
+            (and (eq? 'macosx (system-type))
+                 (find-executable-path "/opt/local/bin/git"))))
+      (define (git . args)
+        (define out (open-output-string))
+        (parameterize ([current-output-port out]
+                       [current-error-port out]
+                       [current-input-port (open-input-string "")]
+                       [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
     ;; guess) and use the sha1 from that file and its date
     (define (from-git-dir)
       (define git-dir (build-path this-dir 'up 'up ".git"))
+      (define branch #f)
       (let loop ([file (build-path git-dir "HEAD")])
-        (let ([l (and (file-exists? file)
-                      (call-with-input-file file read-line))])
-          (cond [(not l) #f]
-                [(regexp-match #rx"^ref: +(.*)$" l)
-                 => (lambda (m)
-                      (loop (build-path git-dir (cadr m))))]
-                [(regexp-match #px"^[[:xdigit:]]{40}$" l)
-                 (format "~a|~a|d"
-                         (file-or-directory-modify-seconds file)
-                         (substring l 0 8))]))))
+        (define l (and (file-exists? file)
+                       (call-with-input-file file read-line)))
+        (cond [(not l) #f]
+              [(regexp-match #rx"^ref: +(.*)$" l)
+               => (λ (m) (unless branch (set! branch (cadr m)))
+                         (loop (build-path git-dir (cadr m))))]
+              [(regexp-match #px"^[[:xdigit:]]{40}$" l)
+               (add-branch (format "~a|~a|d"
+                                   (file-or-directory-modify-seconds file)
+                                   (substring l 0 8))
+                           branch)])))
     ;; fallback: get the date of this file, no id
     (define (from-this-file)
       (format "~a|-|f" (file-or-directory-modify-seconds this-file)))
     (for*/or ([x (list from-archive-id
-                       from-running-git
+                       ;; from-running-git
                        from-git-dir
                        from-this-file)])
       (let* ([x (x)]