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