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