lisp/vc/vc-src.el

   1 ;;; vc-src.el --- support for SRC version-control  -*- lexical-binding:t -*-
   2
   3 ;; Copyright (C) 1992-2014 Free Software Foundation, Inc.
   4
   5 ;; Author:     FSF (see vc.el for full credits)
   6 ;; Maintainer: Eric S. Raymond <esr@thyrsus.com>
   7 ;; Package: vc
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; See vc.el.  SRC requires an underlying RCS version of 4.0 or greater.
  27
  28 ;; FUNCTION NAME                               STATUS
  29 ;; BACKEND PROPERTIES
  30 ;; * revision-granularity                      OK
  31 ;; STATE-QUERYING FUNCTIONS
  32 ;; * registered (file)                         OK
  33 ;; * state (file)                              OK
  34 ;; * dir-status (dir update-function)          OK
  35 ;; - dir-status-files (dir files uf)           ??
  36 ;; - dir-extra-headers (dir)                   NOT NEEDED
  37 ;; - dir-printer (fileinfo)                    ??
  38 ;; * working-revision (file)                   OK
  39 ;; - latest-on-branch-p (file)                 ??
  40 ;; * checkout-model (files)                    OK
  41 ;; - mode-line-string (file)                   NOT NEEDED
  42 ;; STATE-CHANGING FUNCTIONS
  43 ;; * register (files &optional rev comment)    OK
  44 ;; * create-repo ()                            OK
  45 ;; * responsible-p (file)                      OK
  46 ;; - receive-file (file rev)                   NOT NEEDED
  47 ;; - unregister (file)                         NOT NEEDED
  48 ;; * checkin (files comment)                   OK
  49 ;; * find-revision (file rev buffer)           OK
  50 ;; * checkout (file &optional rev)             OK
  51 ;; * revert (file &optional contents-done)     OK
  52 ;; - rollback (files)                          NOT NEEDED
  53 ;; - merge (file rev1 rev2)                    NOT NEEDED
  54 ;; - merge-news (file)                         NOT NEEDED
  55 ;; - steal-lock (file &optional revision)      NOT NEEDED
  56 ;; HISTORY FUNCTIONS
  57 ;; * print-log (files buffer &optional shortlog start-revision limit) OK
  58 ;; - log-view-mode ()                          ??
  59 ;; - show-log-entry (revision)                 NOT NEEDED
  60 ;; - comment-history (file)                    NOT NEEDED
  61 ;; - update-changelog (files)                  NOT NEEDED
  62 ;; * diff (files &optional rev1 rev2 buffer)   OK
  63 ;; - revision-completion-table (files)         ??
  64 ;; - annotate-command (file buf &optional rev) ??
  65 ;; - annotate-time ()                          ??
  66 ;; - annotate-current-time ()                  NOT NEEDED
  67 ;; - annotate-extract-revision-at-line ()      ??
  68 ;; TAG SYSTEM
  69 ;; - create-tag (dir name branchp)             ??
  70 ;; - retrieve-tag (dir name update)            ??
  71 ;; MISCELLANEOUS
  72 ;; - make-version-backups-p (file)             ??
  73 ;; - previous-revision (file rev)              ??
  74 ;; - next-revision (file rev)                  ??
  75 ;; - check-headers ()                          ??
  76 ;; - delete-file (file)                        ??
  77 ;; * rename-file (old new)                     OK
  78 ;; - find-file-hook ()                         NOT NEEDED
  79
  80
  81 ;;; Code:
  82
  83 ;;;
  84 ;;; Customization options
  85 ;;;
  86
  87 (eval-when-compile
  88   (require 'cl-lib)
  89   (require 'vc))
  90
  91 (defgroup vc-src nil
  92   "VC SRC backend."
  93   :version "25.1"
  94   :group 'vc)
  95
  96 (defcustom vc-src-release nil
  97   "The release number of your SRC installation, as a string.
  98 If nil, VC itself computes this value when it is first needed."
  99   :type '(choice (const :tag "Auto" nil)
 100                  (string :tag "Specified")
 101                  (const :tag "Unknown" unknown))
 102   :group 'vc-src)
 103
 104 (defcustom vc-src-program "src"
 105   "Name of the SRC executable (excluding any arguments)."
 106   :type 'string
 107   :group 'vc-src)
 108
 109 (defcustom vc-src-diff-switches nil
 110   "String or list of strings specifying switches for SRC diff under VC.
 111 If nil, use the value of `vc-diff-switches'.  If t, use no switches."
 112   :type '(choice (const :tag "Unspecified" nil)
 113                  (const :tag "None" t)
 114                  (string :tag "Argument String")
 115                  (repeat :tag "Argument List" :value ("") string))
 116   :group 'vc-src)
 117
 118 ;; This needs to be autoloaded because vc-src-registered uses it (via
 119 ;; vc-default-registered), and vc-hooks needs to be able to check
 120 ;; for a registered backend without loading every backend.
 121 ;;;###autoload
 122 (defcustom vc-src-master-templates
 123   (purecopy '("%s.src/%s,v"))
 124   "Where to look for SRC master files.
 125 For a description of possible values, see `vc-check-master-templates'."
 126   :type '(choice (const :tag "Use standard SRC file names"
 127                         '("%s.src/%s,v"))
 128                  (repeat :tag "User-specified"
 129                          (choice string
 130                                  function)))
 131   :group 'vc-src)
 132
 133 \f
 134 ;;; Properties of the backend
 135
 136 (defun vc-src-revision-granularity () 'file)
 137 (defun vc-src-checkout-model (_files) 'implicit)
 138
 139 ;;;
 140 ;;; State-querying functions
 141 ;;;
 142
 143 ;; The autoload cookie below places vc-src-registered directly into
 144 ;; loaddefs.el, so that vc-src.el does not need to be loaded for
 145 ;; every file that is visited.
 146 ;;;###autoload
 147 (progn
 148 (defun vc-src-registered (f) (vc-default-registered 'src f)))
 149
 150 (defun vc-src-state (file)
 151   "SRC-specific version of `vc-state'."
 152   (let*
 153       ((status nil)
 154        (default-directory (file-name-directory file))
 155        (out
 156         (with-output-to-string
 157           (with-current-buffer
 158               standard-output
 159             (setq status
 160                   ;; Ignore all errors.
 161                   (condition-case nil
 162                       (process-file
 163                        vc-src-program nil t nil
 164                        "status" "-a" (file-relative-name file))
 165                     (error nil)))))))
 166     (when (eq 0 status)
 167       (when (null (string-match "does not exist or is unreadable" out))
 168         (let ((state (aref out 0)))
 169           (cond
 170            ;; FIXME: What to do about A and L codes?
 171            ((eq state ?.) 'up-to-date)
 172            ((eq state ?A) 'added)
 173            ((eq state ?M) 'edited)
 174            ((eq state ?I) 'ignored)
 175            ((eq state ?R) 'removed)
 176            ((eq state ?!) 'missing)
 177            ((eq state ??) 'unregistered)
 178            (t 'up-to-date)))))))
 179
 180 (autoload 'vc-expand-dirs "vc")
 181
 182 (defun vc-src-dir-status (dir update-function)
 183   ;; FIXME: Use one src status -a call for this
 184   (let ((flist (vc-expand-dirs (list dir) 'SRC))
 185         (result nil))
 186     (dolist (file flist)
 187       (let ((state (vc-state file))
 188             (frel (file-relative-name file)))
 189         (when (and (eq (vc-backend file) 'SRC)
 190                    (not (eq state 'up-to-date)))
 191           (push (list frel state) result))))
 192     (funcall update-function result)))
 193
 194 (defun vc-src-command (buffer file-or-list &rest flags)
 195   "A wrapper around `vc-do-command' for use in vc-src.el.
 196 This function differs from vc-do-command in that it invokes `vc-src-program'."
 197   (apply 'vc-do-command (or buffer "*vc*") 0 vc-src-program file-or-list flags))
 198
 199 (defun vc-src-working-revision (file)
 200   "SRC-specific version of `vc-working-revision'."
 201   (or (ignore-errors
 202         (with-output-to-string
 203           (vc-src-command standard-output file "list" "-f{1}" "@")))
 204       "0"))
 205
 206 ;;;
 207 ;;; State-changing functions
 208 ;;;
 209
 210 (defun vc-src-create-repo ()
 211   "Create a new SRC repository."
 212   ;; SRC is totally file-oriented, so all we have to do is make the directory.
 213   (make-directory ".src"))
 214
 215 (autoload 'vc-switches "vc")
 216
 217 (defun vc-src-register (files &optional _comment)
 218   "Register FILES under src. COMMENT is ignored."
 219   (vc-src-command nil files "add"))
 220
 221 (defun vc-src-responsible-p (file)
 222   "Return non-nil if SRC thinks it would be responsible for registering FILE."
 223   (file-directory-p (expand-file-name ".src"
 224                                       (if (file-directory-p file)
 225                                           file
 226                                         (file-name-directory file)))))
 227
 228 (defun vc-src-checkin (files comment)
 229   "SRC-specific version of `vc-backend-checkin'.
 230 REV is ignored."
 231   (vc-src-command nil files "commit" "-m" comment))
 232
 233 (defun vc-src-find-revision (file rev buffer)
 234   (let ((coding-system-for-read 'binary)
 235         (coding-system-for-write 'binary))
 236     (if rev
 237         (vc-src-command buffer file "cat" rev)
 238       (vc-src-command buffer file "cat"))))
 239
 240 (defun vc-src-checkout (file &optional rev)
 241   "Retrieve a revision of FILE.
 242 REV is the revision to check out into WORKFILE."
 243   (if rev
 244       (vc-src-command nil file "co" rev)
 245     (vc-src-command nil file "co")))
 246
 247 (defun vc-src-revert (file &optional _contents-done)
 248   "Revert FILE to the version it was based on.  If FILE is a directory,
 249 revert all registered files beneath it."
 250   (if (file-directory-p file)
 251       (mapc 'vc-src-revert (vc-expand-dirs (list file) 'SRC))
 252     (vc-src-command nil file "co")))
 253
 254 (defun vc-src-modify-change-comment (files rev comment)
 255   "Modify the change comments change on FILES on a specified REV.  If FILE is a
 256 directory the operation is applied to all registered files beneath it."
 257   (dolist (file (vc-expand-dirs files 'SRC))
 258     (vc-src-command nil file "amend" "-m" comment rev)))
 259
 260 ;; History functions
 261
 262 (defcustom vc-src-log-switches nil
 263   "String or list of strings specifying switches for src log under VC."
 264   :type '(choice (const :tag "None" nil)
 265                  (string :tag "Argument String")
 266                  (repeat :tag "Argument List" :value ("") string))
 267   :group 'vc-src)
 268
 269 (defun vc-src-print-log (files buffer &optional shortlog _start-revision limit)
 270   "Print commit log associated with FILES into specified BUFFER.
 271 If SHORTLOG is non-nil, use the list method.
 272 If START-REVISION is non-nil, it is the newest revision to show.
 273 If LIMIT is non-nil, show no more than this many entries."
 274   ;; FIXME: Implement the range restrictions.
 275   ;; `vc-do-command' creates the buffer, but we need it before running
 276   ;; the command.
 277   (vc-setup-buffer buffer)
 278   ;; If the buffer exists from a previous invocation it might be
 279   ;; read-only.
 280   (let ((inhibit-read-only t))
 281     (with-current-buffer
 282         buffer
 283       (apply 'vc-src-command buffer files (if shortlog "list" "log")
 284              (nconc
 285               ;;(when start-revision (list (format "%s-1" start-revision)))
 286               (when limit (list "-l" (format "%s" limit)))
 287               vc-src-log-switches)))))
 288
 289 (defun vc-src-diff (files &optional _async oldvers newvers buffer)
 290   "Get a difference report using src between two revisions of FILES."
 291   (let* ((firstfile (car files))
 292          (working (and firstfile (vc-working-revision firstfile))))
 293     (when (and (equal oldvers working) (not newvers))
 294       (setq oldvers nil))
 295     (when (and (not oldvers) newvers)
 296       (setq oldvers working))
 297     (apply #'vc-src-command (or buffer "*vc-diff*") files "diff"
 298            (when oldvers
 299              (if newvers
 300                  (list (concat oldvers "-" newvers))
 301                (list oldvers))))))
 302
 303 ;; Miscellaneous
 304
 305 (defun vc-src-rename-file (old new)
 306   "Rename file from OLD to NEW using `src mv'."
 307   (vc-src-command nil 0 new "mv" old))
 308
 309 (provide 'vc-src)
 310
 311 ;;; vc-src.el ends here