1;;; vc-cvs.el --- non-resident support for CVS version-control 2 3;; Copyright (C) 1995, 1998, 1999, 2000, 2001, 2002, 2003, 4;; 2004, 2005, 2006, 2007 Free Software Foundation, Inc. 5 6;; Author: FSF (see vc.el for full credits) 7;; Maintainer: Andre Spiegel <spiegel@gnu.org> 8 9;; $Id$ 10 11;; This file is part of GNU Emacs. 12 13;; GNU Emacs is free software; you can redistribute it and/or modify 14;; it under the terms of the GNU General Public License as published by 15;; the Free Software Foundation; either version 2, or (at your option) 16;; any later version. 17 18;; GNU Emacs is distributed in the hope that it will be useful, 19;; but WITHOUT ANY WARRANTY; without even the implied warranty of 20;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 21;; GNU General Public License for more details. 22 23;; You should have received a copy of the GNU General Public License 24;; along with GNU Emacs; see the file COPYING. If not, write to the 25;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 26;; Boston, MA 02110-1301, USA. 27 28;;; Commentary: 29 30;;; Code: 31 32(eval-when-compile 33 (require 'vc)) 34 35;;; 36;;; Customization options 37;;; 38 39(defcustom vc-cvs-global-switches nil 40 "*Global switches to pass to any CVS command." 41 :type '(choice (const :tag "None" nil) 42 (string :tag "Argument String") 43 (repeat :tag "Argument List" 44 :value ("") 45 string)) 46 :version "22.1" 47 :group 'vc) 48 49(defcustom vc-cvs-register-switches nil 50 "*Extra switches for registering a file into CVS. 51A string or list of strings passed to the checkin program by 52\\[vc-register]." 53 :type '(choice (const :tag "None" nil) 54 (string :tag "Argument String") 55 (repeat :tag "Argument List" 56 :value ("") 57 string)) 58 :version "21.1" 59 :group 'vc) 60 61(defcustom vc-cvs-diff-switches nil 62 "*A string or list of strings specifying extra switches for cvs diff under VC." 63 :type '(choice (const :tag "None" nil) 64 (string :tag "Argument String") 65 (repeat :tag "Argument List" 66 :value ("") 67 string)) 68 :version "21.1" 69 :group 'vc) 70 71(defcustom vc-cvs-header (or (cdr (assoc 'CVS vc-header-alist)) '("\$Id\$")) 72 "*Header keywords to be inserted by `vc-insert-headers'." 73 :version "21.1" 74 :type '(repeat string) 75 :group 'vc) 76 77(defcustom vc-cvs-use-edit t 78 "*Non-nil means to use `cvs edit' to \"check out\" a file. 79This is only meaningful if you don't use the implicit checkout model 80\(i.e. if you have $CVSREAD set)." 81 :type 'boolean 82 :version "21.1" 83 :group 'vc) 84 85(defcustom vc-cvs-stay-local t 86 "*Non-nil means use local operations when possible for remote repositories. 87This avoids slow queries over the network and instead uses heuristics 88and past information to determine the current status of a file. 89 90The value can also be a regular expression or list of regular 91expressions to match against the host name of a repository; then VC 92only stays local for hosts that match it. Alternatively, the value 93can be a list of regular expressions where the first element is the 94symbol `except'; then VC always stays local except for hosts matched 95by these regular expressions." 96 :type '(choice (const :tag "Always stay local" t) 97 (const :tag "Don't stay local" nil) 98 (list :format "\nExamine hostname and %v" :tag "Examine hostname ..." 99 (set :format "%v" :inline t (const :format "%t" :tag "don't" except)) 100 (regexp :format " stay local,\n%t: %v" :tag "if it matches") 101 (repeat :format "%v%i\n" :inline t (regexp :tag "or")))) 102 :version "21.1" 103 :group 'vc) 104 105(defcustom vc-cvs-sticky-date-format-string "%c" 106 "*Format string for mode-line display of sticky date. 107Format is according to `format-time-string'. Only used if 108`vc-cvs-sticky-tag-display' is t." 109 :type '(string) 110 :version "22.1" 111 :group 'vc) 112 113(defcustom vc-cvs-sticky-tag-display t 114 "*Specify the mode-line display of sticky tags. 115Value t means default display, nil means no display at all. If the 116value is a function or macro, it is called with the sticky tag and 117its' type as parameters, in that order. TYPE can have three different 118values: `symbolic-name' (TAG is a string), `revision-number' (TAG is a 119string) and `date' (TAG is a date as returned by `encode-time'). The 120return value of the function or macro will be displayed as a string. 121 122Here's an example that will display the formatted date for sticky 123dates and the word \"Sticky\" for sticky tag names and revisions. 124 125 (lambda (tag type) 126 (cond ((eq type 'date) (format-time-string 127 vc-cvs-sticky-date-format-string tag)) 128 ((eq type 'revision-number) \"Sticky\") 129 ((eq type 'symbolic-name) \"Sticky\"))) 130 131Here's an example that will abbreviate to the first character only, 132any text before the first occurrence of `-' for sticky symbolic tags. 133If the sticky tag is a revision number, the word \"Sticky\" is 134displayed. Date and time is displayed for sticky dates. 135 136 (lambda (tag type) 137 (cond ((eq type 'date) (format-time-string \"%Y%m%d %H:%M\" tag)) 138 ((eq type 'revision-number) \"Sticky\") 139 ((eq type 'symbolic-name) 140 (condition-case nil 141 (progn 142 (string-match \"\\\\([^-]*\\\\)\\\\(.*\\\\)\" tag) 143 (concat (substring (match-string 1 tag) 0 1) \":\" 144 (substring (match-string 2 tag) 1 nil))) 145 (error tag))))) ; Fall-back to given tag name. 146 147See also variable `vc-cvs-sticky-date-format-string'." 148 :type '(choice boolean function) 149 :version "22.1" 150 :group 'vc) 151 152;;; 153;;; Internal variables 154;;; 155 156 157;;; 158;;; State-querying functions 159;;; 160 161;;;###autoload (defun vc-cvs-registered (f) 162;;;###autoload (when (file-readable-p (expand-file-name 163;;;###autoload "CVS/Entries" (file-name-directory f))) 164;;;###autoload (load "vc-cvs") 165;;;###autoload (vc-cvs-registered f))) 166 167(defun vc-cvs-registered (file) 168 "Check if FILE is CVS registered." 169 (let ((dirname (or (file-name-directory file) "")) 170 (basename (file-name-nondirectory file)) 171 ;; make sure that the file name is searched case-sensitively 172 (case-fold-search nil)) 173 (if (file-readable-p (expand-file-name "CVS/Entries" dirname)) 174 (with-temp-buffer 175 (vc-cvs-get-entries dirname) 176 (goto-char (point-min)) 177 (cond 178 ((re-search-forward 179 ;; CVS-removed files are not taken under VC control. 180 (concat "^/" (regexp-quote basename) "/[^/-]") nil t) 181 (beginning-of-line) 182 (vc-cvs-parse-entry file) 183 t) 184 (t nil))) 185 nil))) 186 187(defun vc-cvs-state (file) 188 "CVS-specific version of `vc-state'." 189 (if (vc-stay-local-p file) 190 (let ((state (vc-file-getprop file 'vc-state))) 191 ;; If we should stay local, use the heuristic but only if 192 ;; we don't have a more precise state already available. 193 (if (memq state '(up-to-date edited nil)) 194 (vc-cvs-state-heuristic file) 195 state)) 196 (with-temp-buffer 197 (cd (file-name-directory file)) 198 (vc-cvs-command t 0 file "status") 199 (vc-cvs-parse-status t)))) 200 201(defun vc-cvs-state-heuristic (file) 202 "CVS-specific state heuristic." 203 ;; If the file has not changed since checkout, consider it `up-to-date'. 204 ;; Otherwise consider it `edited'. 205 (let ((checkout-time (vc-file-getprop file 'vc-checkout-time)) 206 (lastmod (nth 5 (file-attributes file)))) 207 (if (equal checkout-time lastmod) 208 'up-to-date 209 'edited))) 210 211(defun vc-cvs-dir-state (dir) 212 "Find the CVS state of all files in DIR." 213 ;; if DIR is not under CVS control, don't do anything. 214 (when (file-readable-p (expand-file-name "CVS/Entries" dir)) 215 (if (vc-stay-local-p dir) 216 (vc-cvs-dir-state-heuristic dir) 217 (let ((default-directory dir)) 218 ;; Don't specify DIR in this command, the default-directory is 219 ;; enough. Otherwise it might fail with remote repositories. 220 (with-temp-buffer 221 (vc-cvs-command t 0 nil "status" "-l") 222 (goto-char (point-min)) 223 (while (re-search-forward "^=+\n\\([^=\n].*\n\\|\n\\)+" nil t) 224 (narrow-to-region (match-beginning 0) (match-end 0)) 225 (vc-cvs-parse-status) 226 (goto-char (point-max)) 227 (widen))))))) 228 229(defun vc-cvs-workfile-version (file) 230 "CVS-specific version of `vc-workfile-version'." 231 ;; There is no need to consult RCS headers under CVS, because we 232 ;; get the workfile version for free when we recognize that a file 233 ;; is registered in CVS. 234 (vc-cvs-registered file) 235 (vc-file-getprop file 'vc-workfile-version)) 236 237(defun vc-cvs-checkout-model (file) 238 "CVS-specific version of `vc-checkout-model'." 239 (if (getenv "CVSREAD") 240 'announce 241 (let ((attrib (file-attributes file))) 242 (if (and attrib ;; don't check further if FILE doesn't exist 243 ;; If the file is not writable (despite CVSREAD being 244 ;; undefined), this is probably because the file is being 245 ;; "watched" by other developers. 246 ;; (If vc-mistrust-permissions was t, we actually shouldn't 247 ;; trust this, but there is no other way to learn this from CVS 248 ;; at the moment (version 1.9).) 249 (string-match "r-..-..-." (nth 8 attrib))) 250 'announce 251 'implicit)))) 252 253(defun vc-cvs-mode-line-string (file) 254 "Return string for placement into the modeline for FILE. 255Compared to the default implementation, this function does two things: 256Handle the special case of a CVS file that is added but not yet 257committed and support display of sticky tags." 258 (let ((sticky-tag (vc-file-getprop file 'vc-cvs-sticky-tag)) 259 (string (if (string= (vc-workfile-version file) "0") 260 ;; A file that is added but not yet committed. 261 "CVS @@" 262 (vc-default-mode-line-string 'CVS file)))) 263 (if (zerop (length sticky-tag)) 264 string 265 (concat string "[" sticky-tag "]")))) 266 267(defun vc-cvs-dired-state-info (file) 268 "CVS-specific version of `vc-dired-state-info'." 269 (let ((cvs-state (vc-state file))) 270 (cond ((eq cvs-state 'edited) 271 (if (equal (vc-workfile-version file) "0") 272 "(added)" "(modified)")) 273 ((eq cvs-state 'needs-patch) "(patch)") 274 ((eq cvs-state 'needs-merge) "(merge)")))) 275 276 277;;; 278;;; State-changing functions 279;;; 280 281(defun vc-cvs-register (file &optional rev comment) 282 "Register FILE into the CVS version-control system. 283COMMENT can be used to provide an initial description of FILE. 284 285`vc-register-switches' and `vc-cvs-register-switches' are passed to 286the CVS command (in that order)." 287 (when (and (not (vc-cvs-responsible-p file)) 288 (vc-cvs-could-register file)) 289 ;; Register the directory if needed. 290 (vc-cvs-register (directory-file-name (file-name-directory file)))) 291 (apply 'vc-cvs-command nil 0 file 292 "add" 293 (and comment (string-match "[^\t\n ]" comment) 294 (concat "-m" comment)) 295 (vc-switches 'CVS 'register))) 296 297(defun vc-cvs-responsible-p (file) 298 "Return non-nil if CVS thinks it is responsible for FILE." 299 (file-directory-p (expand-file-name "CVS" 300 (if (file-directory-p file) 301 file 302 (file-name-directory file))))) 303 304(defun vc-cvs-could-register (file) 305 "Return non-nil if FILE could be registered in CVS. 306This is only possible if CVS is managing FILE's directory or one of 307its parents." 308 (let ((dir file)) 309 (while (and (stringp dir) 310 (not (equal dir (setq dir (file-name-directory dir)))) 311 dir) 312 (setq dir (if (file-directory-p 313 (expand-file-name "CVS/Entries" dir)) 314 t (directory-file-name dir)))) 315 (eq dir t))) 316 317(defun vc-cvs-checkin (file rev comment) 318 "CVS-specific version of `vc-backend-checkin'." 319 (unless (or (not rev) (vc-cvs-valid-version-number-p rev)) 320 (if (not (vc-cvs-valid-symbolic-tag-name-p rev)) 321 (error "%s is not a valid symbolic tag name" rev) 322 ;; If the input revison is a valid symbolic tag name, we create it 323 ;; as a branch, commit and switch to it. 324 (apply 'vc-cvs-command nil 0 file "tag" "-b" (list rev)) 325 (apply 'vc-cvs-command nil 0 file "update" "-r" (list rev)) 326 (vc-file-setprop file 'vc-cvs-sticky-tag rev))) 327 (let ((status (apply 'vc-cvs-command nil 1 file 328 "ci" (if rev (concat "-r" rev)) 329 (concat "-m" comment) 330 (vc-switches 'CVS 'checkin)))) 331 (set-buffer "*vc*") 332 (goto-char (point-min)) 333 (when (not (zerop status)) 334 ;; Check checkin problem. 335 (cond 336 ((re-search-forward "Up-to-date check failed" nil t) 337 (vc-file-setprop file 'vc-state 'needs-merge) 338 (error (substitute-command-keys 339 (concat "Up-to-date check failed: " 340 "type \\[vc-next-action] to merge in changes")))) 341 (t 342 (pop-to-buffer (current-buffer)) 343 (goto-char (point-min)) 344 (shrink-window-if-larger-than-buffer) 345 (error "Check-in failed")))) 346 ;; Update file properties 347 (vc-file-setprop 348 file 'vc-workfile-version 349 (vc-parse-buffer "^\\(new\\|initial\\) revision: \\([0-9.]+\\)" 2)) 350 ;; Forget the checkout model of the file, because we might have 351 ;; guessed wrong when we found the file. After commit, we can 352 ;; tell it from the permissions of the file (see 353 ;; vc-cvs-checkout-model). 354 (vc-file-setprop file 'vc-checkout-model nil) 355 356 ;; if this was an explicit check-in (does not include creation of 357 ;; a branch), remove the sticky tag. 358 (if (and rev (not (vc-cvs-valid-symbolic-tag-name-p rev))) 359 (vc-cvs-command nil 0 file "update" "-A")))) 360 361(defun vc-cvs-find-version (file rev buffer) 362 (apply 'vc-cvs-command 363 buffer 0 file 364 "-Q" ; suppress diagnostic output 365 "update" 366 (and rev (not (string= rev "")) 367 (concat "-r" rev)) 368 "-p" 369 (vc-switches 'CVS 'checkout))) 370 371(defun vc-cvs-checkout (file &optional editable rev workfile) 372 "Retrieve a revision of FILE into a WORKFILE. 373EDITABLE non-nil means that the file should be writable. 374REV is the revision to check out into WORKFILE." 375 (let ((filename (or workfile file)) 376 (file-buffer (get-file-buffer file)) 377 switches) 378 (message "Checking out %s..." filename) 379 (save-excursion 380 ;; Change buffers to get local value of vc-checkout-switches. 381 (if file-buffer (set-buffer file-buffer)) 382 (setq switches (vc-switches 'CVS 'checkout)) 383 ;; Save this buffer's default-directory 384 ;; and use save-excursion to make sure it is restored 385 ;; in the same buffer it was saved in. 386 (let ((default-directory default-directory)) 387 (save-excursion 388 ;; Adjust the default-directory so that the check-out creates 389 ;; the file in the right place. 390 (setq default-directory (file-name-directory filename)) 391 (if workfile 392 (let ((failed t) 393 (backup-name (if (string= file workfile) 394 (car (find-backup-file-name filename))))) 395 (when backup-name 396 (copy-file filename backup-name 397 'ok-if-already-exists 'keep-date) 398 (unless (file-writable-p filename) 399 (set-file-modes filename 400 (logior (file-modes filename) 128)))) 401 (unwind-protect 402 (progn 403 (let ((coding-system-for-read 'no-conversion) 404 (coding-system-for-write 'no-conversion)) 405 (with-temp-file filename 406 (apply 'vc-cvs-command 407 (current-buffer) 0 file 408 "-Q" ; suppress diagnostic output 409 "update" 410 (and (stringp rev) 411 (not (string= rev "")) 412 (concat "-r" rev)) 413 "-p" 414 switches))) 415 (setq failed nil)) 416 (if failed 417 (if backup-name 418 (rename-file backup-name filename 419 'ok-if-already-exists) 420 (if (file-exists-p filename) 421 (delete-file filename))) 422 (and backup-name 423 (not vc-make-backup-files) 424 (delete-file backup-name))))) 425 (if (and (file-exists-p file) (not rev)) 426 ;; If no revision was specified, just make the file writable 427 ;; if necessary (using `cvs-edit' if requested). 428 (and editable (not (eq (vc-cvs-checkout-model file) 'implicit)) 429 (if vc-cvs-use-edit 430 (vc-cvs-command nil 0 file "edit") 431 (set-file-modes file (logior (file-modes file) 128)) 432 (if file-buffer (toggle-read-only -1)))) 433 ;; Check out a particular version (or recreate the file). 434 (vc-file-setprop file 'vc-workfile-version nil) 435 (apply 'vc-cvs-command nil 0 file 436 (and editable 437 (or (not (file-exists-p file)) 438 (not (eq (vc-cvs-checkout-model file) 439 'implicit))) 440 "-w") 441 "update" 442 (when rev 443 (unless (eq rev t) 444 ;; default for verbose checkout: clear the 445 ;; sticky tag so that the actual update will 446 ;; get the head of the trunk 447 (if (string= rev "") 448 "-A" 449 (concat "-r" rev)))) 450 switches)))) 451 (vc-mode-line file) 452 (message "Checking out %s...done" filename))))) 453 454(defun vc-cvs-delete-file (file) 455 (vc-cvs-command nil 0 file "remove" "-f") 456 (vc-cvs-command nil 0 file "commit" "-mRemoved.")) 457 458(defun vc-cvs-revert (file &optional contents-done) 459 "Revert FILE to the version it was based on." 460 (unless contents-done 461 ;; Check out via standard output (caused by the final argument 462 ;; FILE below), so that no sticky tag is set. 463 (vc-cvs-checkout file nil (vc-workfile-version file) file)) 464 (unless (eq (vc-checkout-model file) 'implicit) 465 (if vc-cvs-use-edit 466 (vc-cvs-command nil 0 file "unedit") 467 ;; Make the file read-only by switching off all w-bits 468 (set-file-modes file (logand (file-modes file) 3950))))) 469 470(defun vc-cvs-merge (file first-version &optional second-version) 471 "Merge changes into current working copy of FILE. 472The changes are between FIRST-VERSION and SECOND-VERSION." 473 (vc-cvs-command nil 0 file 474 "update" "-kk" 475 (concat "-j" first-version) 476 (concat "-j" second-version)) 477 (vc-file-setprop file 'vc-state 'edited) 478 (with-current-buffer (get-buffer "*vc*") 479 (goto-char (point-min)) 480 (if (re-search-forward "conflicts during merge" nil t) 481 1 ; signal error 482 0))) ; signal success 483 484(defun vc-cvs-merge-news (file) 485 "Merge in any new changes made to FILE." 486 (message "Merging changes into %s..." file) 487 ;; (vc-file-setprop file 'vc-workfile-version nil) 488 (vc-file-setprop file 'vc-checkout-time 0) 489 (vc-cvs-command nil 0 file "update") 490 ;; Analyze the merge result reported by CVS, and set 491 ;; file properties accordingly. 492 (with-current-buffer (get-buffer "*vc*") 493 (goto-char (point-min)) 494 ;; get new workfile version 495 (if (re-search-forward 496 "^Merging differences between [0-9.]* and \\([0-9.]*\\) into" nil t) 497 (vc-file-setprop file 'vc-workfile-version (match-string 1)) 498 (vc-file-setprop file 'vc-workfile-version nil)) 499 ;; get file status 500 (prog1 501 (if (eq (buffer-size) 0) 502 0 ;; there were no news; indicate success 503 (if (re-search-forward 504 (concat "^\\([CMUP] \\)?" 505 (regexp-quote (file-name-nondirectory file)) 506 "\\( already contains the differences between \\)?") 507 nil t) 508 (cond 509 ;; Merge successful, we are in sync with repository now 510 ((or (match-string 2) 511 (string= (match-string 1) "U ") 512 (string= (match-string 1) "P ")) 513 (vc-file-setprop file 'vc-state 'up-to-date) 514 (vc-file-setprop file 'vc-checkout-time 515 (nth 5 (file-attributes file))) 516 0);; indicate success to the caller 517 ;; Merge successful, but our own changes are still in the file 518 ((string= (match-string 1) "M ") 519 (vc-file-setprop file 'vc-state 'edited) 520 0);; indicate success to the caller 521 ;; Conflicts detected! 522 (t 523 (vc-file-setprop file 'vc-state 'edited) 524 1);; signal the error to the caller 525 ) 526 (pop-to-buffer "*vc*") 527 (error "Couldn't analyze cvs update result"))) 528 (message "Merging changes into %s...done" file)))) 529 530 531;;; 532;;; History functions 533;;; 534 535(defun vc-cvs-print-log (file &optional buffer) 536 "Get change log associated with FILE." 537 (vc-cvs-command 538 buffer 539 (if (and (vc-stay-local-p file) (fboundp 'start-process)) 'async 0) 540 file "log")) 541 542(defun vc-cvs-diff (file &optional oldvers newvers buffer) 543 "Get a difference report using CVS between two versions of FILE." 544 (if (string= (vc-workfile-version file) "0") 545 ;; This file is added but not yet committed; there is no master file. 546 (if (or oldvers newvers) 547 (error "No revisions of %s exist" file) 548 ;; We regard this as "changed". 549 ;; Diff it against /dev/null. 550 ;; Note: this is NOT a "cvs diff". 551 (apply 'vc-do-command (or buffer "*vc-diff*") 552 1 "diff" file 553 (append (vc-switches nil 'diff) '("/dev/null"))) 554 ;; Even if it's empty, it's locally modified. 555 1) 556 (let* ((async (and (not vc-disable-async-diff) 557 (vc-stay-local-p file) 558 (fboundp 'start-process))) 559 (status (apply 'vc-cvs-command (or buffer "*vc-diff*") 560 (if async 'async 1) 561 file "diff" 562 (and oldvers (concat "-r" oldvers)) 563 (and newvers (concat "-r" newvers)) 564 (vc-switches 'CVS 'diff)))) 565 (if async 1 status)))) ; async diff, pessimistic assumption 566 567(defun vc-cvs-diff-tree (dir &optional rev1 rev2) 568 "Diff all files at and below DIR." 569 (with-current-buffer "*vc-diff*" 570 (setq default-directory dir) 571 (if (vc-stay-local-p dir) 572 ;; local diff: do it filewise, and only for files that are modified 573 (vc-file-tree-walk 574 dir 575 (lambda (f) 576 (vc-exec-after 577 `(let ((coding-system-for-read (vc-coding-system-for-diff ',f))) 578 ;; possible optimization: fetch the state of all files 579 ;; in the tree via vc-cvs-dir-state-heuristic 580 (unless (vc-up-to-date-p ',f) 581 (message "Looking at %s" ',f) 582 (vc-diff-internal ',f ',rev1 ',rev2)))))) 583 ;; cvs diff: use a single call for the entire tree 584 (let ((coding-system-for-read 585 (or coding-system-for-read 'undecided))) 586 (apply 'vc-cvs-command "*vc-diff*" 1 nil "diff" 587 (and rev1 (concat "-r" rev1)) 588 (and rev2 (concat "-r" rev2)) 589 (vc-switches 'CVS 'diff)))))) 590 591(defun vc-cvs-annotate-command (file buffer &optional version) 592 "Execute \"cvs annotate\" on FILE, inserting the contents in BUFFER. 593Optional arg VERSION is a version to annotate from." 594 (vc-cvs-command buffer 0 file "annotate" (if version (concat "-r" version))) 595 (with-current-buffer buffer 596 (goto-char (point-min)) 597 (re-search-forward "^[0-9]") 598 (delete-region (point-min) (1- (point))))) 599 600(defun vc-cvs-annotate-current-time () 601 "Return the current time, based at midnight of the current day, and 602encoded as fractional days." 603 (vc-annotate-convert-time 604 (apply 'encode-time 0 0 0 (nthcdr 3 (decode-time (current-time)))))) 605 606(defun vc-cvs-annotate-time () 607 "Return the time of the next annotation (as fraction of days) 608systime, or nil if there is none." 609 (let* ((bol (point)) 610 (cache (get-text-property bol 'vc-cvs-annotate-time)) 611 buffer-read-only) 612 (cond 613 (cache) 614 ((looking-at 615 "^\\S-+\\s-+\\S-+\\s-+\\([0-9]+\\)-\\(\\sw+\\)-\\([0-9]+\\)): ") 616 (let ((day (string-to-number (match-string 1))) 617 (month (cdr (assq (intern (match-string 2)) 618 '((Jan . 1) (Feb . 2) (Mar . 3) 619 (Apr . 4) (May . 5) (Jun . 6) 620 (Jul . 7) (Aug . 8) (Sep . 9) 621 (Oct . 10) (Nov . 11) (Dec . 12))))) 622 (year (let ((tmp (string-to-number (match-string 3)))) 623 ;; Years 0..68 are 2000..2068. 624 ;; Years 69..99 are 1969..1999. 625 (+ (cond ((> 69 tmp) 2000) 626 ((> 100 tmp) 1900) 627 (t 0)) 628 tmp)))) 629 (put-text-property 630 bol (1+ bol) 'vc-cvs-annotate-time 631 (setq cache (cons 632 ;; Position at end makes for nicer overlay result. 633 (match-end 0) 634 (vc-annotate-convert-time 635 (encode-time 0 0 0 day month year)))))))) 636 (when cache 637 (goto-char (car cache)) ; fontify from here to eol 638 (cdr cache)))) ; days (float) 639 640(defun vc-cvs-annotate-extract-revision-at-line () 641 (save-excursion 642 (beginning-of-line) 643 (if (re-search-forward "^\\([0-9]+\\.[0-9]+\\(\\.[0-9]+\\)*\\) +(" 644 (line-end-position) t) 645 (match-string-no-properties 1) 646 nil))) 647 648;;; 649;;; Snapshot system 650;;; 651 652(defun vc-cvs-create-snapshot (dir name branchp) 653 "Assign to DIR's current version a given NAME. 654If BRANCHP is non-nil, the name is created as a branch (and the current 655workspace is immediately moved to that new branch)." 656 (vc-cvs-command nil 0 dir "tag" "-c" (if branchp "-b") name) 657 (when branchp (vc-cvs-command nil 0 dir "update" "-r" name))) 658 659(defun vc-cvs-retrieve-snapshot (dir name update) 660 "Retrieve a snapshot at and below DIR. 661NAME is the name of the snapshot; if it is empty, do a `cvs update'. 662If UPDATE is non-nil, then update (resynch) any affected buffers." 663 (with-current-buffer (get-buffer-create "*vc*") 664 (let ((default-directory dir) 665 (sticky-tag)) 666 (erase-buffer) 667 (if (or (not name) (string= name "")) 668 (vc-cvs-command t 0 nil "update") 669 (vc-cvs-command t 0 nil "update" "-r" name) 670 (setq sticky-tag name)) 671 (when update 672 (goto-char (point-min)) 673 (while (not (eobp)) 674 (if (looking-at "\\([CMUP]\\) \\(.*\\)") 675 (let* ((file (expand-file-name (match-string 2) dir)) 676 (state (match-string 1)) 677 (buffer (find-buffer-visiting file))) 678 (when buffer 679 (cond 680 ((or (string= state "U") 681 (string= state "P")) 682 (vc-file-setprop file 'vc-state 'up-to-date) 683 (vc-file-setprop file 'vc-workfile-version nil) 684 (vc-file-setprop file 'vc-checkout-time 685 (nth 5 (file-attributes file)))) 686 ((or (string= state "M") 687 (string= state "C")) 688 (vc-file-setprop file 'vc-state 'edited) 689 (vc-file-setprop file 'vc-workfile-version nil) 690 (vc-file-setprop file 'vc-checkout-time 0))) 691 (vc-file-setprop file 'vc-cvs-sticky-tag sticky-tag) 692 (vc-resynch-buffer file t t)))) 693 (forward-line 1)))))) 694 695 696;;; 697;;; Miscellaneous 698;;; 699 700(defalias 'vc-cvs-make-version-backups-p 'vc-stay-local-p 701 "Return non-nil if version backups should be made for FILE.") 702 703(defun vc-cvs-check-headers () 704 "Check if the current file has any headers in it." 705 (save-excursion 706 (goto-char (point-min)) 707 (re-search-forward "\\$[A-Za-z\300-\326\330-\366\370-\377]+\ 708\\(: [\t -#%-\176\240-\377]*\\)?\\$" nil t))) 709 710 711;;; 712;;; Internal functions 713;;; 714 715(defun vc-cvs-command (buffer okstatus file &rest flags) 716 "A wrapper around `vc-do-command' for use in vc-cvs.el. 717The difference to vc-do-command is that this function always invokes `cvs', 718and that it passes `vc-cvs-global-switches' to it before FLAGS." 719 (apply 'vc-do-command buffer okstatus "cvs" file 720 (if (stringp vc-cvs-global-switches) 721 (cons vc-cvs-global-switches flags) 722 (append vc-cvs-global-switches 723 flags)))) 724 725(defalias 'vc-cvs-stay-local-p 'vc-stay-local-p) ;Back-compatibility. 726 727(defun vc-cvs-repository-hostname (dirname) 728 "Hostname of the CVS server associated to workarea DIRNAME." 729 (let ((rootname (expand-file-name "CVS/Root" dirname))) 730 (when (file-readable-p rootname) 731 (with-temp-buffer 732 (let ((coding-system-for-read 733 (or file-name-coding-system 734 default-file-name-coding-system))) 735 (vc-insert-file rootname)) 736 (goto-char (point-min)) 737 (nth 2 (vc-cvs-parse-root 738 (buffer-substring (point) 739 (line-end-position)))))))) 740 741(defun vc-cvs-parse-root (root) 742 "Split CVS ROOT specification string into a list of fields. 743A CVS root specification of the form 744 [:METHOD:][[USER@]HOSTNAME:]/path/to/repository 745is converted to a normalized record with the following structure: 746 \(METHOD USER HOSTNAME CVS-ROOT). 747The default METHOD for a CVS root of the form 748 /path/to/repository 749is `local'. 750The default METHOD for a CVS root of the form 751 [USER@]HOSTNAME:/path/to/repository 752is `ext'. 753For an empty string, nil is returned (invalid CVS root)." 754 ;; Split CVS root into colon separated fields (0-4). 755 ;; The `x:' makes sure, that leading colons are not lost; 756 ;; `HOST:/PATH' is then different from `:METHOD:/PATH'. 757 (let* ((root-list (cdr (split-string (concat "x:" root) ":"))) 758 (len (length root-list)) 759 ;; All syntactic varieties will get a proper METHOD. 760 (root-list 761 (cond 762 ((= len 0) 763 ;; Invalid CVS root 764 nil) 765 ((= len 1) 766 ;; Simple PATH => method `local' 767 (cons "local" 768 (cons nil root-list))) 769 ((= len 2) 770 ;; [USER@]HOST:PATH => method `ext' 771 (and (not (equal (car root-list) "")) 772 (cons "ext" root-list))) 773 ((= len 3) 774 ;; :METHOD:PATH 775 (cons (cadr root-list) 776 (cons nil (cddr root-list)))) 777 (t 778 ;; :METHOD:[USER@]HOST:PATH 779 (cdr root-list))))) 780 (if root-list 781 (let ((method (car root-list)) 782 (uhost (or (cadr root-list) "")) 783 (root (nth 2 root-list)) 784 user host) 785 ;; Split USER@HOST 786 (if (string-match "\\(.*\\)@\\(.*\\)" uhost) 787 (setq user (match-string 1 uhost) 788 host (match-string 2 uhost)) 789 (setq host uhost)) 790 ;; Remove empty HOST 791 (and (equal host "") 792 (setq host)) 793 ;; Fix windows style CVS root `:local:C:\\project\\cvs\\some\\dir' 794 (and host 795 (equal method "local") 796 (setq root (concat host ":" root) host)) 797 ;; Normalize CVS root record 798 (list method user host root))))) 799 800(defun vc-cvs-parse-status (&optional full) 801 "Parse output of \"cvs status\" command in the current buffer. 802Set file properties accordingly. Unless FULL is t, parse only 803essential information." 804 (let (file status) 805 (goto-char (point-min)) 806 (if (re-search-forward "^File: " nil t) 807 (cond 808 ((looking-at "no file") nil) 809 ((re-search-forward "\\=\\([^ \t]+\\)" nil t) 810 (setq file (expand-file-name (match-string 1))) 811 (vc-file-setprop file 'vc-backend 'CVS) 812 (if (not (re-search-forward "\\=[ \t]+Status: \\(.*\\)" nil t)) 813 (setq status "Unknown") 814 (setq status (match-string 1))) 815 (if (and full 816 (re-search-forward 817 "\\(RCS Version\\|RCS Revision\\|Repository revision\\):\ 818\[\t ]+\\([0-9.]+\\)" 819 nil t)) 820 (vc-file-setprop file 'vc-latest-version (match-string 2))) 821 (vc-file-setprop 822 file 'vc-state 823 (cond 824 ((string-match "Up-to-date" status) 825 (vc-file-setprop file 'vc-checkout-time 826 (nth 5 (file-attributes file))) 827 'up-to-date) 828 ((string-match "Locally Modified" status) 'edited) 829 ((string-match "Needs Merge" status) 'needs-merge) 830 ((string-match "Needs \\(Checkout\\|Patch\\)" status) 'needs-patch) 831 (t 'edited)))))))) 832 833(defun vc-cvs-dir-state-heuristic (dir) 834 "Find the CVS state of all files in DIR, using only local information." 835 (with-temp-buffer 836 (vc-cvs-get-entries dir) 837 (goto-char (point-min)) 838 (while (not (eobp)) 839 ;; CVS-removed files are not taken under VC control. 840 (when (looking-at "/\\([^/]*\\)/[^/-]") 841 (let ((file (expand-file-name (match-string 1) dir))) 842 (unless (vc-file-getprop file 'vc-state) 843 (vc-cvs-parse-entry file t)))) 844 (forward-line 1)))) 845 846(defun vc-cvs-get-entries (dir) 847 "Insert the CVS/Entries file from below DIR into the current buffer. 848This function ensures that the correct coding system is used for that, 849which may not be the one that is used for the files' contents. 850CVS/Entries should only be accessed through this function." 851 (let ((coding-system-for-read (or file-name-coding-system 852 default-file-name-coding-system))) 853 (vc-insert-file (expand-file-name "CVS/Entries" dir)))) 854 855(defun vc-cvs-valid-symbolic-tag-name-p (tag) 856 "Return non-nil if TAG is a valid symbolic tag name." 857 ;; According to the CVS manual, a valid symbolic tag must start with 858 ;; an uppercase or lowercase letter and can contain uppercase and 859 ;; lowercase letters, digits, `-', and `_'. 860 (and (string-match "^[a-zA-Z]" tag) 861 (not (string-match "[^a-z0-9A-Z-_]" tag)))) 862 863(defun vc-cvs-valid-version-number-p (tag) 864 "Return non-nil if TAG is a valid version number." 865 (and (string-match "^[0-9]" tag) 866 (not (string-match "[^0-9.]" tag)))) 867 868(defun vc-cvs-parse-sticky-tag (match-type match-tag) 869 "Parse and return the sticky tag as a string. 870`match-data' is protected." 871 (let ((data (match-data)) 872 (tag) 873 (type (cond ((string= match-type "D") 'date) 874 ((string= match-type "T") 875 (if (vc-cvs-valid-symbolic-tag-name-p match-tag) 876 'symbolic-name 877 'revision-number)) 878 (t nil)))) 879 (unwind-protect 880 (progn 881 (cond 882 ;; Sticky Date tag. Convert to a proper date value (`encode-time') 883 ((eq type 'date) 884 (string-match 885 "\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)" 886 match-tag) 887 (let* ((year-tmp (string-to-number (match-string 1 match-tag))) 888 (month (string-to-number (match-string 2 match-tag))) 889 (day (string-to-number (match-string 3 match-tag))) 890 (hour (string-to-number (match-string 4 match-tag))) 891 (min (string-to-number (match-string 5 match-tag))) 892 (sec (string-to-number (match-string 6 match-tag))) 893 ;; Years 0..68 are 2000..2068. 894 ;; Years 69..99 are 1969..1999. 895 (year (+ (cond ((> 69 year-tmp) 2000) 896 ((> 100 year-tmp) 1900) 897 (t 0)) 898 year-tmp))) 899 (setq tag (encode-time sec min hour day month year)))) 900 ;; Sticky Tag name or revision number 901 ((eq type 'symbolic-name) (setq tag match-tag)) 902 ((eq type 'revision-number) (setq tag match-tag)) 903 ;; Default is no sticky tag at all 904 (t nil)) 905 (cond ((eq vc-cvs-sticky-tag-display nil) nil) 906 ((eq vc-cvs-sticky-tag-display t) 907 (cond ((eq type 'date) (format-time-string 908 vc-cvs-sticky-date-format-string 909 tag)) 910 ((eq type 'symbolic-name) tag) 911 ((eq type 'revision-number) tag) 912 (t nil))) 913 ((functionp vc-cvs-sticky-tag-display) 914 (funcall vc-cvs-sticky-tag-display tag type)) 915 (t nil))) 916 917 (set-match-data data)))) 918 919(defun vc-cvs-parse-entry (file &optional set-state) 920 "Parse a line from CVS/Entries. 921Compare modification time to that of the FILE, set file properties 922accordingly. However, `vc-state' is set only if optional arg SET-STATE 923is non-nil." 924 (cond 925 ;; entry for a "locally added" file (not yet committed) 926 ((looking-at "/[^/]+/0/") 927 (vc-file-setprop file 'vc-checkout-time 0) 928 (vc-file-setprop file 'vc-workfile-version "0") 929 (if set-state (vc-file-setprop file 'vc-state 'edited))) 930 ;; normal entry 931 ((looking-at 932 (concat "/[^/]+" 933 ;; revision 934 "/\\([^/]*\\)" 935 ;; timestamp and optional conflict field 936 "/\\([^/]*\\)/" 937 ;; options 938 "\\([^/]*\\)/" 939 ;; sticky tag 940 "\\(.\\|\\)" ;Sticky tag type (date or tag name, could be empty) 941 "\\(.*\\)")) ;Sticky tag 942 (vc-file-setprop file 'vc-workfile-version (match-string 1)) 943 (vc-file-setprop file 'vc-cvs-sticky-tag 944 (vc-cvs-parse-sticky-tag (match-string 4) 945 (match-string 5))) 946 ;; Compare checkout time and modification time. 947 ;; This is intentionally different from the algorithm that CVS uses 948 ;; (which is based on textual comparison), because there can be problems 949 ;; generating a time string that looks exactly like the one from CVS. 950 (let ((mtime (nth 5 (file-attributes file)))) 951 (require 'parse-time) 952 (let ((parsed-time 953 (parse-time-string (concat (match-string 2) " +0000")))) 954 (cond ((and (not (string-match "\\+" (match-string 2))) 955 (car parsed-time) 956 (equal mtime (apply 'encode-time parsed-time))) 957 (vc-file-setprop file 'vc-checkout-time mtime) 958 (if set-state (vc-file-setprop file 'vc-state 'up-to-date))) 959 (t 960 (vc-file-setprop file 'vc-checkout-time 0) 961 (if set-state (vc-file-setprop file 'vc-state 'edited))))))))) 962 963(provide 'vc-cvs) 964 965;;; arch-tag: 60e1402a-aa53-4607-927a-cf74f144b432 966;;; vc-cvs.el ends here 967