contrib/lisp/org-git-link.el

   1 ;;; org-git-link.el --- Provide org links to specific file version
   2
   3 ;; Copyright (C) 2009-2014  Reimar Finken
   4
   5 ;; Author: Reimar Finken <reimar.finken@gmx.de>
   6 ;; Keywords: files, calendar, hypermedia
   7
   8 ;; This file is not part of GNU Emacs.
   9
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; This program is distaributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; `org-git-link.el' defines two new link types. The `git' link
  26 ;; type is meant to be used in the typical scenario and mimics the
  27 ;; `file' link syntax as closely as possible. The `gitbare' link
  28 ;; type exists mostly for debugging reasons, but also allows e.g.
  29 ;; linking to files in a bare git repository for the experts.
  30
  31 ;; * User friendy form
  32 ;;   [[git:/path/to/file::searchstring]]
  33
  34 ;;   This form is the familiar from normal org file links
  35 ;;   including search options. However, its use is
  36 ;;   restricted to files in a working directory and does not
  37 ;;   handle bare repositories on purpose (see the bare form for
  38 ;;   that).
  39
  40 ;;   The search string references a commit (a tree-ish in Git
  41 ;;   terminology). The two most useful types of search strings are
  42
  43 ;;   - A symbolic ref name, usually a branch or tag name (e.g.
  44 ;;     master or nobelprize).
  45 ;;   - A ref followed by the suffix @ with a date specification
  46 ;;     enclosed in a brace pair (e.g. {yesterday}, {1 month 2
  47 ;;     weeks 3 days 1 hour 1 second ago} or {1979-02-26 18:30:00})
  48 ;;     to specify the value of the ref at a prior point in time
  49 ;;
  50 ;; * Bare git form
  51 ;;   [[gitbare:$GIT_DIR::$OBJECT]]
  52 ;;
  53 ;;    This is the more bare metal version, which gives the user most
  54 ;;    control. It directly translates to the git command
  55 ;;    git --no-pager --git-dir=$GIT_DIR show $OBJECT
  56 ;;    Using this version one can also view files from a bare git
  57 ;;    repository. For detailed information on how to specify an
  58 ;;    object, see the man page of `git-rev-parse' (section
  59 ;;    SPECIFYING REVISIONS). A specific blob (file) can be
  60 ;;    specified by a suffix clolon (:) followed by a path.
  61
  62 ;;; Code:
  63 \f
  64 (require 'org)
  65 (defcustom org-git-program "git"
  66   "Name of the git executable used to follow git links."
  67   :type '(string)
  68   :group 'org)
  69
  70 ;; org link functions
  71 ;; bare git link
  72 (org-add-link-type "gitbare" 'org-gitbare-open)
  73
  74 (defun org-gitbare-open (str)
  75   (let* ((strlist (org-git-split-string str))
  76          (gitdir (first strlist))
  77          (object (second strlist)))
  78     (org-git-open-file-internal gitdir object)))
  79
  80
  81 (defun org-git-open-file-internal (gitdir object)
  82   (let* ((sha (org-git-blob-sha gitdir object))
  83          (tmpdir (concat temporary-file-directory "org-git-" sha))
  84          (filename (org-git-link-filename object))
  85          (tmpfile (expand-file-name filename tmpdir)))
  86     (unless (file-readable-p tmpfile)
  87       (make-directory tmpdir)
  88       (with-temp-file tmpfile
  89         (org-git-show gitdir object (current-buffer))))
  90     (org-open-file tmpfile)
  91     (set-buffer (get-file-buffer tmpfile))
  92     (setq buffer-read-only t)))
  93
  94 ;; user friendly link
  95 (org-add-link-type "git" 'org-git-open)
  96
  97 (defun org-git-open (str)
  98   (let* ((strlist (org-git-split-string str))
  99          (filepath (first strlist))
 100          (commit (second strlist))
 101          (line (third strlist))
 102          (dirlist (org-git-find-gitdir (file-truename filepath)))
 103          (gitdir (first dirlist))
 104          (relpath (second dirlist)))
 105     (org-git-open-file-internal gitdir (concat commit ":" relpath))
 106     (when line (goto-line (string-to-int line)))))
 107
 108 \f
 109 ;; Utility functions (file names etc)
 110
 111 (defun org-git-split-dirpath (dirpath)
 112   "Given a directory name, return '(dirname basname)"
 113   (let ((dirname (file-name-directory (directory-file-name dirpath)))
 114         (basename (file-name-nondirectory (directory-file-name dirpath))))
 115     (list dirname basename)))
 116
 117 ;; finding the git directory
 118 (defun org-git-find-gitdir (path)
 119   "Given a file (not necessarily existing) file path, return the
 120   a pair (gitdir relpath), where gitdir is the path to the first
 121   .git subdirectory found updstream and relpath is the rest of
 122   the path. Example: (org-git-find-gitdir
 123   \"~/gitrepos/foo/bar.txt\") returns
 124   '(\"/home/user/gitrepos/.git\" \"foo/bar.txt\"). When not in a git repository, return nil."
 125   (let ((dir (file-name-directory path))
 126         (relpath (file-name-nondirectory path)))
 127     (catch 'toplevel
 128       (while (not (file-exists-p (expand-file-name ".git" dir)))
 129         (let ((dirlist (org-git-split-dirpath dir)))
 130           (when (string= (second dirlist) "") ; at top level
 131             (throw 'toplevel nil))
 132           (setq dir (first dirlist)
 133                 relpath (concat (file-name-as-directory (second dirlist)) relpath))))
 134       (list (expand-file-name ".git" dir) relpath))))
 135
 136
 137 (eval-and-compile
 138   (if (featurep 'xemacs)
 139       (defalias 'org-git-gitrepos-p 'org-git-find-gitdir)
 140     (defalias 'org-git-gitrepos-p 'org-git-find-gitdir
 141       "Return non-nil if path is in git repository")))
 142
 143 ;; splitting the link string
 144
 145 ;; Both link open functions are called with a string of
 146 ;; consisting of three parts separated by a double colon (::).
 147 (defun org-git-split-string (str)
 148   "Given a string of the form \"str1::str2::str3\", return a list of
 149   three substrings \'(\"str1\" \"str2\" \"str3\"). If there are less
 150 than two double colons, str2 and/or str3 may be set the empty string."
 151   (let ((strlist (split-string str "::")))
 152     (cond ((= 1 (length strlist))
 153            (list (car strlist) "" ""))
 154           ((= 2 (length strlist))
 155            (append strlist (list "")))
 156           ((= 3 (length strlist))
 157            strlist)
 158           (t (error "org-git-split-string: only one or two :: allowed: %s" str)))))
 159
 160 ;; finding the file name part of a commit
 161 (defun org-git-link-filename (str)
 162   "Given an object description (see the man page of
 163   git-rev-parse), return the nondirectory part of the referenced
 164   filename, if it can be extracted. Otherwise, return a valid
 165   filename."
 166   (let* ((match (and (string-match "[^:]+$" str)
 167                      (match-string 0 str)))
 168          (filename (and match (file-name-nondirectory match)))) ;extract the final part without slash
 169     filename))
 170
 171 ;; creating a link
 172 (defun org-git-create-searchstring (branch timestring)
 173   (concat branch "@{" timestring "}"))
 174
 175
 176 (defun org-git-create-git-link (file &optional line)
 177   "Create git link part to file at specific time"
 178   (interactive "FFile: ")
 179   (let* ((gitdir (first (org-git-find-gitdir (file-truename file))))
 180          (branchname (org-git-get-current-branch gitdir))
 181          (timestring (format-time-string "%Y-%m-%d" (current-time))))
 182     (concat "git:" file "::" (org-git-create-searchstring branchname timestring)
 183             (if line (format "::%s" line) ""))))
 184
 185 (defun org-git-store-link ()
 186   "Store git link to current file."
 187   (when (buffer-file-name)
 188     (let ((file (abbreviate-file-name (buffer-file-name)))
 189           (line (line-number-at-pos)))
 190       (when (org-git-gitrepos-p file)
 191         (org-store-link-props
 192          :type "git"
 193          :link (org-git-create-git-link file line))))))
 194
 195 (add-hook 'org-store-link-functions 'org-git-store-link)
 196
 197 (defun org-git-insert-link-interactively (file searchstring &optional description)
 198   (interactive "FFile: \nsSearch string: \nsDescription: ")
 199   (insert (org-make-link-string (concat "git:" file "::" searchstring) description)))
 200 \f
 201 ;; Calling git
 202 (defun org-git-show (gitdir object buffer)
 203   "Show the output of git --git-dir=gitdir show object in buffer."
 204   (unless
 205       (zerop (call-process org-git-program nil buffer nil
 206                            "--no-pager" (concat "--git-dir=" gitdir) "show" object))
 207     (error "git error: %s " (with-current-buffer buffer (buffer-string)))))
 208
 209 (defun org-git-blob-sha (gitdir object)
 210   "Return sha of the referenced object"
 211     (with-temp-buffer
 212       (if (zerop (call-process org-git-program nil t nil
 213                                "--no-pager" (concat "--git-dir=" gitdir) "rev-parse" object))
 214           (buffer-substring (point-min) (1- (point-max))) ; to strip off final newline
 215         (error "git error: %s " (buffer-string)))))
 216
 217 (defun org-git-get-current-branch (gitdir)
 218   "Return the name of the current branch."
 219   (with-temp-buffer
 220     (if (not (zerop (call-process org-git-program nil t nil
 221                                   "--no-pager" (concat "--git-dir=" gitdir) "symbolic-ref" "-q" "HEAD")))
 222         (error "git error: %s " (buffer-string))
 223       (goto-char (point-min))
 224       (if (looking-at "^refs/heads/")   ; 11 characters
 225           (buffer-substring 12 (1- (point-max))))))) ; to strip off final newline
 226
 227 (provide 'org-git-link)
 228
 229 ;;; org-git-link.el ends here