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