mirror of
https://git.savannah.gnu.org/git/emacs/org-mode.git
synced 2024-09-12 09:09:54 +00:00
e85080 is the last correct commit in the maint branch before releasing 7.8.04. The 7.8.05 release should be done from this commit.
221 lines
8.6 KiB
EmacsLisp
221 lines
8.6 KiB
EmacsLisp
;;; org-git-link.el --- Provide org links to specific file version
|
||
|
||
;; Copyright (C) 2009-2011 Reimar Finken
|
||
|
||
;; Author: Reimar Finken <reimar.finken@gmx.de>
|
||
;; Keywords: files, calendar, hypermedia
|
||
|
||
;; This program is free software; you can redistribute it and/or modify
|
||
;; it under the terms of the GNU General Public License as published by
|
||
;; the Free Software Foundation, either version 3 of the License, or
|
||
;; (at your option) any later version.
|
||
|
||
;; This program is distaributed in the hope that it will be useful,
|
||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;; GNU General Public License for more details.
|
||
|
||
;; You should have received a copy of the GNU General Public License
|
||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||
|
||
;;; Commentary:
|
||
|
||
;; `org-git-link.el' defines two new link types. The `git' link
|
||
;; type is meant to be used in the typical scenario and mimics the
|
||
;; `file' link syntax as closely as possible. The `gitbare' link
|
||
;; type exists mostly for debugging reasons, but also allows e.g.
|
||
;; linking to files in a bare git repository for the experts.
|
||
|
||
;; * User friendy form
|
||
;; [[git:/path/to/file::searchstring]]
|
||
|
||
;; This form is the familiar from normal org file links
|
||
;; including search options. However, its use is
|
||
;; restricted to files in a working directory and does not
|
||
;; handle bare repositories on purpose (see the bare form for
|
||
;; that).
|
||
|
||
;; The search string references a commit (a tree-ish in Git
|
||
;; terminology). The two most useful types of search strings are
|
||
|
||
;; - A symbolic ref name, usually a branch or tag name (e.g.
|
||
;; master or nobelprize).
|
||
;; - A ref followed by the suffix @ with a date specification
|
||
;; enclosed in a brace pair (e.g. {yesterday}, {1 month 2
|
||
;; weeks 3 days 1 hour 1 second ago} or {1979-02-26 18:30:00})
|
||
;; to specify the value of the ref at a prior point in time
|
||
;;
|
||
;; * Bare git form
|
||
;; [[gitbare:$GIT_DIR::$OBJECT]]
|
||
;;
|
||
;; This is the more bare metal version, which gives the user most
|
||
;; control. It directly translates to the git command
|
||
;; git --no-pager --git-dir=$GIT_DIR show $OBJECT
|
||
;; Using this version one can also view files from a bare git
|
||
;; repository. For detailed information on how to specify an
|
||
;; object, see the man page of `git-rev-parse' (section
|
||
;; SPECIFYING REVISIONS). A specific blob (file) can be
|
||
;; specified by a suffix clolon (:) followed by a path.
|
||
|
||
;;; Code:
|
||
|
||
(require 'org)
|
||
(defcustom org-git-program "git"
|
||
"Name of the git executable used to follow git links."
|
||
:type '(string)
|
||
:group 'org)
|
||
|
||
;; org link functions
|
||
;; bare git link
|
||
(org-add-link-type "gitbare" 'org-gitbare-open)
|
||
|
||
(defun org-gitbare-open (str)
|
||
(let* ((strlist (org-git-split-string str))
|
||
(gitdir (first strlist))
|
||
(object (second strlist)))
|
||
(org-git-open-file-internal gitdir object)))
|
||
|
||
|
||
(defun org-git-open-file-internal (gitdir object)
|
||
(let* ((sha (org-git-blob-sha gitdir object))
|
||
(tmpdir (concat temporary-file-directory "org-git-" sha))
|
||
(filename (org-git-link-filename object))
|
||
(tmpfile (expand-file-name filename tmpdir)))
|
||
(unless (file-readable-p tmpfile)
|
||
(make-directory tmpdir)
|
||
(with-temp-file tmpfile
|
||
(org-git-show gitdir object (current-buffer))))
|
||
(org-open-file tmpfile)
|
||
(set-buffer (get-file-buffer tmpfile))
|
||
(setq buffer-read-only t)))
|
||
|
||
;; user friendly link
|
||
(org-add-link-type "git" 'org-git-open)
|
||
|
||
(defun org-git-open (str)
|
||
(let* ((strlist (org-git-split-string str))
|
||
(filepath (first strlist))
|
||
(commit (second strlist))
|
||
(dirlist (org-git-find-gitdir (file-truename filepath)))
|
||
(gitdir (first dirlist))
|
||
(relpath (second dirlist)))
|
||
(org-git-open-file-internal gitdir (concat commit ":" relpath))))
|
||
|
||
|
||
;; Utility functions (file names etc)
|
||
|
||
(defun org-git-split-dirpath (dirpath)
|
||
"Given a directory name, return '(dirname basname)"
|
||
(let ((dirname (file-name-directory (directory-file-name dirpath)))
|
||
(basename (file-name-nondirectory (directory-file-name dirpath))))
|
||
(list dirname basename)))
|
||
|
||
;; finding the git directory
|
||
(defun org-git-find-gitdir (path)
|
||
"Given a file (not necessarily existing) file path, return the
|
||
a pair (gitdir relpath), where gitdir is the path to the first
|
||
.git subdirectory found updstream and relpath is the rest of
|
||
the path. Example: (org-git-find-gitdir
|
||
\"~/gitrepos/foo/bar.txt\") returns
|
||
'(\"/home/user/gitrepos/.git\" \"foo/bar.txt\"). When not in a git repository, return nil."
|
||
(let ((dir (file-name-directory path))
|
||
(relpath (file-name-nondirectory path)))
|
||
(catch 'toplevel
|
||
(while (not (file-exists-p (expand-file-name ".git" dir)))
|
||
(let ((dirlist (org-git-split-dirpath dir)))
|
||
(when (string= (second dirlist) "") ; at top level
|
||
(throw 'toplevel nil))
|
||
(setq dir (first dirlist)
|
||
relpath (concat (file-name-as-directory (second dirlist)) relpath))))
|
||
(list (expand-file-name ".git" dir) relpath))))
|
||
|
||
|
||
(if (featurep 'xemacs)
|
||
(defalias 'org-git-gitrepos-p 'org-git-find-gitdir)
|
||
(defalias 'org-git-gitrepos-p 'org-git-find-gitdir
|
||
"Return non-nil if path is in git repository"))
|
||
|
||
;; splitting the link string
|
||
|
||
;; Both link open functions are called with a string of
|
||
;; consisting of two parts separated by a double colon (::).
|
||
(defun org-git-split-string (str)
|
||
"Given a string of the form \"str1::str2\", return a list of
|
||
two substrings \'(\"str1\" \"str2\"). If the double colon is mising, take str2 to be the empty string."
|
||
(let ((strlist (split-string str "::")))
|
||
(cond ((= 1 (length strlist))
|
||
(list (car strlist) ""))
|
||
((= 2 (length strlist))
|
||
strlist)
|
||
(t (error "org-git-split-string: only one :: allowed: %s" str)))))
|
||
|
||
;; finding the file name part of a commit
|
||
(defun org-git-link-filename (str)
|
||
"Given an object description (see the man page of
|
||
git-rev-parse), return the nondirectory part of the referenced
|
||
filename, if it can be extracted. Otherwise, return a valid
|
||
filename."
|
||
(let* ((match (and (string-match "[^:]+$" str)
|
||
(match-string 0 str)))
|
||
(filename (and match (file-name-nondirectory match)))) ;extract the final part without slash
|
||
filename))
|
||
|
||
;; creating a link
|
||
(defun org-git-create-searchstring (branch timestring)
|
||
(concat branch "@{" timestring "}"))
|
||
|
||
|
||
(defun org-git-create-git-link (file)
|
||
"Create git link part to file at specific time"
|
||
(interactive "FFile: ")
|
||
(let* ((gitdir (first (org-git-find-gitdir (file-truename file))))
|
||
(branchname (org-git-get-current-branch gitdir))
|
||
(timestring (format-time-string "%Y-%m-%d" (current-time))))
|
||
(org-make-link "git:" file "::" (org-git-create-searchstring branchname timestring))))
|
||
|
||
(defun org-git-store-link ()
|
||
"Store git link to current file."
|
||
(when (buffer-file-name)
|
||
(let ((file (abbreviate-file-name (buffer-file-name))))
|
||
(when (org-git-gitrepos-p file)
|
||
(org-store-link-props
|
||
:type "git"
|
||
:link (org-git-create-git-link file))))))
|
||
|
||
(add-hook 'org-store-link-functions 'org-git-store-link)
|
||
|
||
(defun org-git-insert-link-interactively (file searchstring &optional description)
|
||
(interactive "FFile: \nsSearch string: \nsDescription: ")
|
||
(insert (org-make-link-string (org-make-link "git:" file "::" searchstring) description)))
|
||
|
||
;; Calling git
|
||
(defun org-git-show (gitdir object buffer)
|
||
"Show the output of git --git-dir=gitdir show object in buffer."
|
||
(unless
|
||
(zerop (call-process org-git-program nil buffer nil
|
||
"--no-pager" (concat "--git-dir=" gitdir) "show" object))
|
||
(error "git error: %s " (save-excursion (set-buffer buffer)
|
||
(buffer-string)))))
|
||
|
||
(defun org-git-blob-sha (gitdir object)
|
||
"Return sha of the referenced object"
|
||
(with-temp-buffer
|
||
(if (zerop (call-process org-git-program nil t nil
|
||
"--no-pager" (concat "--git-dir=" gitdir) "rev-parse" object))
|
||
(buffer-substring (point-min) (1- (point-max))) ; to strip off final newline
|
||
(error "git error: %s " (buffer-string)))))
|
||
|
||
(defun org-git-get-current-branch (gitdir)
|
||
"Return the name of the current branch."
|
||
(with-temp-buffer
|
||
(if (not (zerop (call-process org-git-program nil t nil
|
||
"--no-pager" (concat "--git-dir=" gitdir) "symbolic-ref" "-q" "HEAD")))
|
||
(error "git error: %s " (buffer-string))
|
||
(goto-char (point-min))
|
||
(if (looking-at "^refs/heads/") ; 11 characters
|
||
(buffer-substring 12 (1- (point-max))))))) ; to strip off final newline
|
||
|
||
(provide 'org-git-link)
|
||
|
||
;;; org-git-link.el ends here
|