Mercurial > hg > xemacs-beta
comparison lisp/packages/generic-sc.el @ 155:43dd3413c7c7 r20-3b4
Import from CVS: tag r20-3b4
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 09:39:39 +0200 |
| parents | |
| children |
comparison
equal
deleted
inserted
replaced
| 154:94141801dd7e | 155:43dd3413c7c7 |
|---|---|
| 1 ;;; generic-sc.el --- generic interface to source control systems | |
| 2 | |
| 3 ;; Copyright (C) 1992, 1993, 1994, 1997 Free Software Foundation, Inc. | |
| 4 | |
| 5 ;; Author: devin@lucid.com | |
| 6 ;; Maintainer: Unmaintained | |
| 7 ;; Keywords: tools, unix | |
| 8 | |
| 9 ;; This file is part of XEmacs. | |
| 10 | |
| 11 ;; XEmacs is free software; you can redistribute it and/or modify it | |
| 12 ;; under the terms of the GNU General Public License as published by | |
| 13 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 14 ;; any later version. | |
| 15 | |
| 16 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 19 ;; General Public License for more details. | |
| 20 | |
| 21 ;; You should have received a copy of the GNU General Public License | |
| 22 ;; along with XEmacs; see the file COPYING. If not, write to the | |
| 23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 24 ;; Boston, MA 02111-1307, USA. | |
| 25 | |
| 26 ;;; Synched up with: Not in FSF. | |
| 27 | |
| 28 ;;; Commentary: | |
| 29 | |
| 30 ;; The generic interface provide a common set of functions that can be | |
| 31 ;; used to interface with a source control system like SCCS, RCS or | |
| 32 ;; CVS. | |
| 33 ;; | |
| 34 ;; You chose which source control system to use by calling sc-mode | |
| 35 ;; | |
| 36 ;; The module is based on the sccs.el mode of Eric S. Raymond | |
| 37 ;; (eric@snark.thyrsus.com) which was distantly derived from an rcs | |
| 38 ;; mode written by Ed Simpson ({decvax, seismo}!mcnc!duke!dukecdu!evs) | |
| 39 ;; in years gone by and revised at MIT's Project Athena. | |
| 40 | |
| 41 ;;; Code: | |
| 42 | |
| 43 ;; This can be customized by the user | |
| 44 | |
| 45 (defgroup generic-sc nil | |
| 46 "Generic interface to source control systems" | |
| 47 :prefix "sc-" | |
| 48 :group 'tools) | |
| 49 | |
| 50 | |
| 51 (defcustom sc-diff-command '("diff") | |
| 52 "*The command/flags list to be used in constructing diff commands." | |
| 53 :type '(repeat string) | |
| 54 :group 'generic-sc) | |
| 55 | |
| 56 ;; Duplicated from pcl-cvs. | |
| 57 (defvar cvs-program "cvs" | |
| 58 "*The command name of the cvs program.") | |
| 59 | |
| 60 (defcustom sc-mode-expert () | |
| 61 "*Treat user as expert; suppress yes-no prompts on some things." | |
| 62 :type 'boolean | |
| 63 :group 'generic-sc) | |
| 64 | |
| 65 (defcustom sc-max-log-size 510 | |
| 66 "*Maximum allowable size of a source control log message." | |
| 67 :type 'integer | |
| 68 :group 'generic-sc) | |
| 69 | |
| 70 (defcustom sc-ccase-comment-on '(checkout checkout-dir checkin-dir rename | |
| 71 new-brtype new-branch checkin-merge | |
| 72 create-label label-sources) | |
| 73 "*Operations on which comments would be appreciated. | |
| 74 We check the values checkout, checkout-dir, checkin-dir, | |
| 75 rename, new-brtype, new-branch, create-label, | |
| 76 and label-sources as symbols." | |
| 77 :type '(repeat symbol) | |
| 78 :group 'generic-sc) | |
| 79 | |
| 80 (defvar sc-ccase-reserve nil | |
| 81 "Whether to reserve checkouts or not. By default, this is nil - don't. | |
| 82 Other values are t - do, and anything else, eg. 'ask - ask.") | |
| 83 | |
| 84 ;; default keybindings | |
| 85 (defvar sc-prefix-map (lookup-key global-map "\C-xv")) | |
| 86 (if (not (keymapp sc-prefix-map)) | |
| 87 (progn | |
| 88 (setq sc-prefix-map (make-sparse-keymap)) | |
| 89 (define-key global-map "\C-xv" sc-prefix-map) | |
| 90 (define-key sc-prefix-map "v" 'sc-next-operation) | |
| 91 (define-key sc-prefix-map "=" 'sc-show-changes) | |
| 92 (define-key sc-prefix-map "l" 'sc-show-history) | |
| 93 (define-key sc-prefix-map "p" 'sc-visit-previous-revision) | |
| 94 (define-key sc-prefix-map "u" 'sc-revert-file) | |
| 95 (define-key sc-prefix-map "d" 'sc-list-registered-files) | |
| 96 (define-key sc-prefix-map "\C-d" 'sc-update-directory) | |
| 97 (define-key sc-prefix-map "\C-r" 'sc-rename-file) | |
| 98 )) | |
| 99 | |
| 100 | |
| 101 ;;; The user does not change these | |
| 102 (defvar sc-generic-name "" | |
| 103 "Name of the source control system used. Is displayed in the modeline.") | |
| 104 | |
| 105 (defvar sc-mode-line-string () | |
| 106 "Revision number to show in the mode line") | |
| 107 | |
| 108 (defvar sc-generic-log-buf () | |
| 109 "Buffer for entering log message") | |
| 110 | |
| 111 (defvar sc-log-entry-keymap () | |
| 112 "Additional keybindings used when entering the log message") | |
| 113 | |
| 114 (defvar sc-can-hack-dir () | |
| 115 "Does the SC system allow users to play directly with directories") | |
| 116 | |
| 117 (defvar sc-ccase-mfs-prefixes () | |
| 118 "Prefixes known to the system to be MFS ... ignore all others") | |
| 119 | |
| 120 (defmacro sc-chmod (perms file) | |
| 121 (list 'call-process "chmod" nil nil nil perms file)) | |
| 122 | |
| 123 (defmacro error-occurred (&rest body) | |
| 124 (list 'condition-case nil (cons 'progn (append body '(nil))) '(error t))) | |
| 125 | |
| 126 | |
| 127 ;;; User level functions | |
| 128 (defun sc-next-operation (verbose) | |
| 129 "Do the next logical source-control operation on the file in the current buffer. | |
| 130 The current subdirectory must be under source control. | |
| 131 If the file is not already registered with the source control, this registers it | |
| 132 and checks it out. | |
| 133 If the file is registered and not locked by anyone, this checks it out. | |
| 134 If the file is registered and locked by the calling user, this pops up a | |
| 135 buffer for creation of a log message, then checks the file in. | |
| 136 A read-only copy of the changed file is left in place afterwards. | |
| 137 If the file is registered and locked by someone else, an error message is | |
| 138 returned indicating who has locked it." | |
| 139 (interactive "P") | |
| 140 (if (not buffer-file-name) | |
| 141 (error "There is no file associated with buffer %s" (buffer-name))) | |
| 142 (let* (revision | |
| 143 (file buffer-file-name) | |
| 144 (lock-info (sc-lock-info file)) | |
| 145 (sc-generic-log-buf | |
| 146 (get-buffer-create (format "*%s-Log*" sc-generic-name)))) | |
| 147 (if (eq lock-info 'na) | |
| 148 (error "The file associated with buffer %s is not registered" (buffer-name))) | |
| 149 | |
| 150 ;; if file is not registered register it and set lock-info to show it's not locked | |
| 151 (if (not lock-info) | |
| 152 (progn | |
| 153 (sc-register-file verbose) | |
| 154 (setq lock-info (list () ())))) | |
| 155 | |
| 156 (cond ((not (car lock-info)) | |
| 157 ;; if there is no lock on the file, assert one and get it | |
| 158 (sc-check-out file t) | |
| 159 (revert-buffer nil t) | |
| 160 (sc-mode-line)) | |
| 161 | |
| 162 ((and (not (equal sc-generic-name "CCase")) | |
| 163 (not (equal (car lock-info) (user-login-name)))) | |
| 164 ;; file is locked by someone else | |
| 165 (error "Sorry, %s has that file locked." (car lock-info))) | |
| 166 | |
| 167 (t | |
| 168 ;; OK, user owns the lock on the file | |
| 169 ;; if so, give user a chance to save before delta-ing. | |
| 170 (if (and (buffer-modified-p) | |
| 171 (or | |
| 172 sc-mode-expert | |
| 173 (y-or-n-p (format "%s has been modified. Write it out? " | |
| 174 (buffer-name))))) | |
| 175 (save-buffer)) | |
| 176 | |
| 177 (setq revision (car (cdr lock-info))) | |
| 178 | |
| 179 ;; user may want to set nonstandard parameters | |
| 180 (if verbose | |
| 181 (if (or sc-mode-expert | |
| 182 (y-or-n-p | |
| 183 (format "revision: %s Change revision level? " | |
| 184 revision))) | |
| 185 (setq revision (read-string "New revision level: ")))) | |
| 186 | |
| 187 ;; OK, let's do the delta | |
| 188 (let ((buffer (sc-temp-buffer))) | |
| 189 (if (save-window-excursion | |
| 190 ;; this excursion returns t if the new version was saved OK | |
| 191 (pop-to-buffer buffer) | |
| 192 (erase-buffer) | |
| 193 (set-buffer-modified-p nil) | |
| 194 (sc-log-entry-mode) | |
| 195 (message | |
| 196 "Enter log message. Type C-c C-c when done, C-c ? for help.") | |
| 197 (prog1 | |
| 198 (and (not (error-occurred (recursive-edit))) | |
| 199 (not (error-occurred | |
| 200 (sc-check-in file revision | |
| 201 (buffer-string))))) | |
| 202 (setq buffer-file-name nil) | |
| 203 (bury-buffer buffer))) | |
| 204 | |
| 205 ;; if the save went OK do some post-checking | |
| 206 (if (buffer-modified-p) | |
| 207 (error | |
| 208 "Checked-in version of file does not match buffer!") | |
| 209 (revert-buffer nil t) | |
| 210 (sc-mode-line) | |
| 211 (run-hooks 'sc-check-in-ok)))))))) | |
| 212 | |
| 213 (defun sc-insert-last-log () | |
| 214 "Insert the log message of the last check in at point." | |
| 215 (interactive) | |
| 216 (insert-buffer sc-generic-log-buf)) | |
| 217 | |
| 218 (defun sc-abort-check-in () | |
| 219 "Abort a source control check-in command." | |
| 220 (interactive) | |
| 221 (if (or sc-mode-expert (y-or-n-p "Really Abort Check-in? ")) | |
| 222 (progn | |
| 223 (delete-window) | |
| 224 (abort-recursive-edit)))) | |
| 225 | |
| 226 (defun sc-log-exit () | |
| 227 "Proceed with checkin with the contents of the current buffer as message." | |
| 228 (interactive) | |
| 229 (if (< (buffer-size) sc-max-log-size) | |
| 230 (progn | |
| 231 (copy-to-buffer sc-generic-log-buf (point-min) (point-max)) | |
| 232 (exit-recursive-edit) | |
| 233 (delete-window)) | |
| 234 (goto-char sc-max-log-size) | |
| 235 (error | |
| 236 "Log must be less than %d characters. Point is now at char %d." | |
| 237 sc-max-log-size (point)))) | |
| 238 | |
| 239 | |
| 240 ;;; Functions to look at the edit history | |
| 241 (defun sc-show-changes (arg) | |
| 242 "Compare the version being edited with the last checked-in revision. | |
| 243 With a prefix argument prompt for revision to compare with." | |
| 244 (interactive "P") | |
| 245 ;; check that the file is not modified | |
| 246 (if (and (buffer-modified-p) | |
| 247 (or | |
| 248 sc-mode-expert | |
| 249 (y-or-n-p (format "%s has been modified. Write it out? " | |
| 250 (buffer-name))))) | |
| 251 (save-buffer)) | |
| 252 (let* ((revision (and arg (read-string "Revision to compare against: "))) | |
| 253 (file buffer-file-name) | |
| 254 (name (file-name-nondirectory file)) | |
| 255 (old (sc-get-version-in-temp-file file revision)) | |
| 256 (buffer (sc-temp-buffer)) | |
| 257 status) | |
| 258 (save-excursion | |
| 259 (set-buffer buffer) | |
| 260 (erase-buffer) | |
| 261 (setq default-directory (file-name-directory file)) | |
| 262 (setq status | |
| 263 (apply 'call-process (car sc-diff-command) () t () | |
| 264 (append (cdr sc-diff-command) (list old) (list file))))) | |
| 265 (if (not (or (eq 0 status) (eq 1 status))) ; see man diff.1 | |
| 266 (progn | |
| 267 (display-buffer buffer) | |
| 268 (error "diff FAILED"))) | |
| 269 (delete-file old) | |
| 270 (save-excursion | |
| 271 (set-buffer buffer) | |
| 272 (goto-char (point-min)) | |
| 273 (if (equal (point-min) (point-max)) | |
| 274 (insert | |
| 275 (format "No changes to %s since last update." | |
| 276 (file-name-nondirectory file))) | |
| 277 (insert "==== Diffs for " file "\n") | |
| 278 (insert "==== ") | |
| 279 (mapcar '(lambda (i) (insert i " ")) sc-diff-command) | |
| 280 (insert name "<" (or revision "current") ">" " " name "\n\n"))) | |
| 281 (display-buffer buffer))) | |
| 282 | |
| 283 (defun sc-show-revision-changes () | |
| 284 "Prompt for a revision to diff against." | |
| 285 (interactive) | |
| 286 (sc-show-changes 4)) | |
| 287 | |
| 288 (defun sc-version-diff-file (file rel1 rel2) | |
| 289 "For FILE, report diffs between two revisions REL1 and REL2 of it." | |
| 290 (interactive "fFile: \nsOlder version: \nsNewer version: ") | |
| 291 (if (string-equal rel1 "") (setq rel1 nil)) | |
| 292 (if (string-equal rel2 "") (setq rel2 nil)) | |
| 293 (let ((buffer (sc-temp-buffer))) | |
| 294 (set-buffer buffer) | |
| 295 (erase-buffer) | |
| 296 (let ((v1 (sc-get-version-in-temp-file file rel1)) | |
| 297 (v2 (if rel2 (sc-get-version-in-temp-file file rel2) file))) | |
| 298 (and v1 | |
| 299 v2 | |
| 300 (unwind-protect | |
| 301 (apply 'call-process (car sc-diff-command) nil t t | |
| 302 (append (cdr sc-diff-command) (list v1) (list v2))))) | |
| 303 (condition-case () (delete-file v1) (error nil)) | |
| 304 (if rel2 | |
| 305 (condition-case () (delete-file v2) (error nil))) | |
| 306 (set-buffer-modified-p nil) | |
| 307 (goto-char (point-min)) | |
| 308 (if (equal (point-min) (point-max)) | |
| 309 (message | |
| 310 (format "No changes to %s between %s and %s." file rel1 rel2)) | |
| 311 (display-buffer buffer))))) | |
| 312 | |
| 313 (defun sc-show-history () | |
| 314 "List the edit history of the current buffer." | |
| 315 (interactive) | |
| 316 (let ((file buffer-file-name)) | |
| 317 (if (not file) | |
| 318 (error "There is no file associated with buffer %s" (buffer-name))) | |
| 319 (if (not (sc-lock-info file)) | |
| 320 (error "The file is not registered in the source control system")) | |
| 321 (let ((buffer (sc-temp-buffer))) | |
| 322 (save-excursion | |
| 323 (set-buffer buffer) | |
| 324 (erase-buffer) | |
| 325 (sc-history file) | |
| 326 (goto-char (point-min))) | |
| 327 (display-buffer buffer)))) | |
| 328 | |
| 329 (defun sc-visit-previous-revision (revision) | |
| 330 "Show a previous revision of the current file" | |
| 331 (interactive "sShow previous revision number: ") | |
| 332 (let ((file buffer-file-name)) | |
| 333 (if (not file) | |
| 334 (error "There is no file associated with buffer %s" (buffer-name))) | |
| 335 (let ((other-file (sc-get-version-in-temp-file file revision)) | |
| 336 (buffer-name (concat (file-name-nondirectory file) | |
| 337 "<" sc-generic-name " " revision ">"))) | |
| 338 (pop-to-buffer (get-buffer-create buffer-name)) | |
| 339 (erase-buffer) | |
| 340 (insert-file other-file) | |
| 341 ;; get the same major mode as the original file | |
| 342 (setq buffer-file-name file) | |
| 343 (normal-mode) | |
| 344 (setq buffer-file-name ()) | |
| 345 (set-buffer-modified-p ()) | |
| 346 (toggle-read-only) | |
| 347 (delete-file other-file)))) | |
| 348 | |
| 349 (defun sc-revert-file () | |
| 350 "Revert the current buffer's file back to the last saved version." | |
| 351 (interactive) | |
| 352 (let ((file buffer-file-name)) | |
| 353 (if (y-or-n-p (format "Revert file %s to last checked-in revision?" file)) | |
| 354 (progn | |
| 355 (sc-revert file) | |
| 356 (revert-buffer nil t) | |
| 357 (sc-mode-line))))) | |
| 358 | |
| 359 ;; Functions to get directory level information | |
| 360 | |
| 361 (defun sc-list-all-locked-files (arg) | |
| 362 "List all files currently locked under the revision control system. | |
| 363 With prefix arg list only the files locked by the user." | |
| 364 (interactive "P") | |
| 365 (let* ((locker (and arg (user-login-name))) | |
| 366 (buffer (sc-tree-walk 'sc-list-file-if-locked locker))) | |
| 367 (save-excursion | |
| 368 (set-buffer buffer) | |
| 369 (goto-char (point-min)) | |
| 370 (if (= (point-min) (point-max)) | |
| 371 (insert "No files locked ") | |
| 372 (insert "Files locked ")) | |
| 373 (if locker | |
| 374 (insert "by " locker " ")) | |
| 375 (insert "in " default-directory "\n\n")) | |
| 376 (display-buffer buffer))) | |
| 377 | |
| 378 (defun sc-list-locked-files () | |
| 379 "List all files currently locked by me" | |
| 380 (interactive) | |
| 381 (sc-list-all-locked-files 4)) | |
| 382 | |
| 383 (defun sc-list-registered-files () | |
| 384 "List all files currently registered under the revision control system." | |
| 385 (interactive) | |
| 386 (let ((buffer (sc-tree-walk 'sc-list-file))) | |
| 387 (save-excursion | |
| 388 (set-buffer buffer) | |
| 389 (if (= (point-min) (point-max)) | |
| 390 (insert "No files registered in " sc-generic-name | |
| 391 " in " default-directory) | |
| 392 (goto-char (point-min)) | |
| 393 (insert "Files registered in " sc-generic-name " in " default-directory | |
| 394 "\n\n"))) | |
| 395 (display-buffer buffer))) | |
| 396 | |
| 397 (defun sc-update-directory () | |
| 398 "Updates the current directory by getting the latest copies of the files" | |
| 399 (interactive) | |
| 400 (save-some-buffers) | |
| 401 (let ((buffer (sc-tree-walk 'sc-update-file))) | |
| 402 (save-excursion | |
| 403 (set-buffer buffer) | |
| 404 (goto-char (point-min)) | |
| 405 (if (= (point-min) (point-max)) | |
| 406 (insert "No files needed to be updated in " default-directory "\n\n") | |
| 407 (insert "Files updated in " default-directory "\n\n"))) | |
| 408 (display-buffer buffer))) | |
| 409 | |
| 410 ;; Miscellaneous other entry points | |
| 411 | |
| 412 (defun sc-register-file (verbose) | |
| 413 "Register the file visited by the current buffer into source control. | |
| 414 Prefix argument register it under an explicit revision number." | |
| 415 (interactive "P") | |
| 416 (let ((file buffer-file-name)) | |
| 417 (if (not file) | |
| 418 (error "There is no file associated with buffer %s" (buffer-name))) | |
| 419 (let ((lock-info (sc-lock-info file)) | |
| 420 (revision ())) | |
| 421 (if lock-info | |
| 422 (error "This file is already registered into %s" sc-generic-name)) | |
| 423 ;; propose to save the file if it's modified | |
| 424 (if (and (buffer-modified-p) | |
| 425 (or | |
| 426 sc-mode-expert | |
| 427 (y-or-n-p (format "%s has been modified. Write it out? " | |
| 428 (buffer-name))))) | |
| 429 (save-buffer)) | |
| 430 ;; get the revision number | |
| 431 (if verbose | |
| 432 (setq revision (read-string "Initial Revision Number: "))) | |
| 433 (sc-register file revision) | |
| 434 (revert-buffer nil t) | |
| 435 (sc-mode-line)))) | |
| 436 | |
| 437 (defun sc-rename-file (old new) | |
| 438 "Rename a file, taking its source control archive with it." | |
| 439 (interactive "fOld name: \nFNew name: ") | |
| 440 (let ((owner (sc-locking-user old))) | |
| 441 (if (and owner (not (string-equal owner (user-login-name)))) | |
| 442 (error "Sorry, %s has that file checked out" owner))) | |
| 443 (if sc-can-hack-dir | |
| 444 (rename-file old new t)) | |
| 445 (sc-rename old new)) | |
| 446 | |
| 447 (defun sc-rename-this-file (new) | |
| 448 "Rename the file of the current buffer, taking its source control archive with it" | |
| 449 (interactive "FNew name: ") | |
| 450 (if (and (buffer-modified-p) | |
| 451 (y-or-n-p (format "%s has been modified. Write it out? " | |
| 452 (buffer-name)))) | |
| 453 (save-buffer)) | |
| 454 (sc-rename-file buffer-file-name new) | |
| 455 (let ((old-buffer (current-buffer)) | |
| 456 (new-buffer (find-file-noselect new))) | |
| 457 (set-window-buffer (selected-window) new-buffer) | |
| 458 (pop-to-buffer (current-buffer)) | |
| 459 (bury-buffer old-buffer))) | |
| 460 | |
| 461 | |
| 462 ;;; Mode independent functions | |
| 463 ;;; All those sc-... functions FUNCALL the corresponding sc-generic-... function. | |
| 464 ;;; The variables are set to functions that do the SCCS, RCS or CVS commands | |
| 465 ;;; depending on the mode chosen. | |
| 466 | |
| 467 (defvar sc-generic-lock-info () | |
| 468 "Function to implement sc-lock-info") | |
| 469 | |
| 470 (defun sc-lock-info (file) | |
| 471 "Return a list of the current locker and current locked revision for FILE. | |
| 472 Returns NIL if FILE is not registered in the source control system. | |
| 473 Return (NIL NIL) if FILE is registered but not locked. | |
| 474 Return (locker revision) if file is locked." | |
| 475 (funcall sc-generic-lock-info file)) | |
| 476 | |
| 477 | |
| 478 (defvar sc-generic-register () | |
| 479 "Function to implement sc-register") | |
| 480 | |
| 481 (defun sc-register (file revision) | |
| 482 "Register FILE under source control with initial revision REVISION." | |
| 483 (funcall sc-generic-register file revision)) | |
| 484 | |
| 485 | |
| 486 (defvar sc-generic-check-out () | |
| 487 "Function to implement sc-check-out") | |
| 488 | |
| 489 (defun sc-check-out (file lockp) | |
| 490 "Checks out the latest version of FILE. | |
| 491 If LOCKP is not NIL, FILE is also locked." | |
| 492 (funcall sc-generic-check-out file lockp)) | |
| 493 | |
| 494 | |
| 495 (defvar sc-generic-get-version () | |
| 496 "Function to implement sc-get-version") | |
| 497 | |
| 498 (defun sc-get-version (file buffer revision) | |
| 499 "Insert a previous revison of FILE in BUFFER. | |
| 500 REVISION is the revision number requested." | |
| 501 (funcall sc-generic-get-version file buffer revision)) | |
| 502 | |
| 503 | |
| 504 (defvar sc-generic-check-in () | |
| 505 "Function to implement sc-check-in") | |
| 506 | |
| 507 (defun sc-check-in (file revision message) | |
| 508 "Check in FILE with revision REVISION. | |
| 509 MESSAGE is a string describing the changes." | |
| 510 (funcall sc-generic-check-in file revision message)) | |
| 511 | |
| 512 | |
| 513 (defvar sc-generic-history () | |
| 514 "Function to implement sc-history") | |
| 515 | |
| 516 (defun sc-history (file) | |
| 517 "Insert the edit history of FILE in the current buffer." | |
| 518 (funcall sc-generic-history file)) | |
| 519 | |
| 520 | |
| 521 (defvar sc-generic-tree-list () | |
| 522 "Function to implement sc-tree-list") | |
| 523 | |
| 524 (defun sc-tree-list () | |
| 525 "List in the current buffer the files registered in the source control system" | |
| 526 (funcall sc-generic-tree-list)) | |
| 527 | |
| 528 | |
| 529 (defvar sc-generic-new-revision-p () | |
| 530 "Function to implement sc-new-revision-p") | |
| 531 | |
| 532 (defun sc-new-revision-p (file) | |
| 533 "True if a new revision of FILE was checked in since we last got a copy of it" | |
| 534 (funcall sc-generic-new-revision-p file)) | |
| 535 | |
| 536 | |
| 537 (defvar sc-generic-revert () | |
| 538 "Function to implement sc-revert") | |
| 539 | |
| 540 (defun sc-revert (file) | |
| 541 "Cancel a check out of FILE and get back the latest checked in version" | |
| 542 (funcall sc-generic-revert file)) | |
| 543 | |
| 544 | |
| 545 (defvar sc-generic-rename () | |
| 546 "Function to implement sc-rename") | |
| 547 | |
| 548 (defun sc-rename (old new) | |
| 549 "Rename the source control archives for OLD to NEW" | |
| 550 (funcall sc-generic-rename old new)) | |
| 551 | |
| 552 | |
| 553 (defvar sc-menu () | |
| 554 "Menu to use") | |
| 555 | |
| 556 | |
| 557 ;;; Utilities functions | |
| 558 (defun sc-do-command (buffer message command file sc-file &rest flags) | |
| 559 "Execute a command, notifying the user and checking for errors." | |
| 560 (setq file (expand-file-name file)) | |
| 561 (message "Running %s on %s..." message file) | |
| 562 (let ((status | |
| 563 (save-excursion | |
| 564 (set-buffer (get-buffer-create buffer)) | |
| 565 (erase-buffer) | |
| 566 (setq flags (append flags (and file (list sc-file)))) | |
| 567 (setq flags (delq () flags)) | |
| 568 (let ((default-directory (file-name-directory (or file "./")))) | |
| 569 (eq (apply 'call-process command nil t nil flags) 0))))) | |
| 570 (if status | |
| 571 (message "Running %s...OK" message) | |
| 572 (save-excursion | |
| 573 (set-buffer buffer) | |
| 574 (goto-char (point-min)) | |
| 575 (insert command) | |
| 576 (mapcar '(lambda (i) (insert " " i)) flags) | |
| 577 (insert "\n\n") | |
| 578 (goto-char (point-min))) | |
| 579 (display-buffer buffer) | |
| 580 (error "Running %s...FAILED" message)))) | |
| 581 | |
| 582 (defun sc-enter-comment () | |
| 583 "Enter a comment. Return it as a string." | |
| 584 (let ((buffer (sc-temp-buffer))) | |
| 585 (setq sc-generic-log-buf | |
| 586 (get-buffer-create (format "*%s-Log*" sc-generic-name))) | |
| 587 (save-window-excursion | |
| 588 ;; this excursion returns t if the new version was saved OK | |
| 589 (pop-to-buffer buffer) | |
| 590 (erase-buffer) | |
| 591 (set-buffer-modified-p nil) | |
| 592 (sc-log-entry-mode) | |
| 593 (message | |
| 594 "Enter log message. Type C-c C-c when done, C-c ? for help.") | |
| 595 (prog1 | |
| 596 (and (not (error-occurred (recursive-edit))) | |
| 597 (let ((bs (buffer-string))) | |
| 598 (if (> (length bs) 0) bs))) | |
| 599 (setq buffer-file-name nil) | |
| 600 (bury-buffer buffer))))) | |
| 601 | |
| 602 (defun sc-locking-user (file) | |
| 603 "Return the login name of the locker of FILE. Return nil if FILE is not locked" | |
| 604 (car (sc-lock-info file))) | |
| 605 | |
| 606 (defun sc-locked-revision (file) | |
| 607 "Return the revision number currently locked for FILE, nil if FILE is not locked." | |
| 608 (car (cdr (sc-lock-info file)))) | |
| 609 | |
| 610 (defun sc-mode-line () | |
| 611 "Set the mode line for the current buffer. | |
| 612 FILE is the file being visited." | |
| 613 (let* ((file buffer-file-name) | |
| 614 (lock-info (sc-lock-info file))) | |
| 615 ;; ensure that the global mode string is not NIL | |
| 616 (or global-mode-string (setq global-mode-string '(""))) | |
| 617 ;; ensure that our variable is in the global-mode-string | |
| 618 (or (memq 'sc-mode-line-string global-mode-string) | |
| 619 (setq global-mode-string | |
| 620 (append global-mode-string '(sc-mode-line-string)))) | |
| 621 (make-local-variable 'sc-mode-line-string) | |
| 622 (setq sc-mode-line-string | |
| 623 (cond ((or | |
| 624 (eq lock-info 'na) | |
| 625 (null lock-info)) ()) | |
| 626 ((null (car lock-info)) | |
| 627 (format " <%s:>" sc-generic-name)) | |
| 628 ((equal (car lock-info) (user-login-name)) | |
| 629 (format " <%s: %s>" sc-generic-name (car (cdr lock-info)))) | |
| 630 (t | |
| 631 (format " <%s: %s>" sc-generic-name (car lock-info))))))) | |
| 632 | |
| 633 (defun sc-temp-buffer () | |
| 634 "Return a temporary buffer to use for output" | |
| 635 (get-buffer-create (format "*%s*" sc-generic-name))) | |
| 636 | |
| 637 (defun sc-tree-walk (func &rest args) | |
| 638 "Apply FUNC to the files registered in the source control system. | |
| 639 FUNC is passed the file path and ARGS." | |
| 640 (let* ((buffer-name (format "*%s directory*" sc-generic-name)) | |
| 641 (buffer (get-buffer-create buffer-name)) | |
| 642 (dir default-directory) | |
| 643 files) | |
| 644 ;; recreate the directory buffer in the right directory | |
| 645 (save-excursion | |
| 646 (set-buffer buffer) | |
| 647 (erase-buffer) | |
| 648 (setq default-directory dir) | |
| 649 ;; get a list of all the registered files | |
| 650 (sc-tree-list) | |
| 651 ;; remove the "not found" messages | |
| 652 (goto-char (point-min)) | |
| 653 (while (search-forward "not found" () t) | |
| 654 (beginning-of-line 1) | |
| 655 (kill-line 1)) | |
| 656 ;; check if any file is listed | |
| 657 (if (= (point-min) (point-max)) | |
| 658 (error "No registered files under %s" default-directory)) | |
| 659 ;; build the list of files | |
| 660 (goto-char (point-min)) | |
| 661 (setq files ()) | |
| 662 (while (not (eobp)) | |
| 663 (let ((file | |
| 664 (buffer-substring (point) (progn (end-of-line) (point))))) | |
| 665 (setq files (cons file files))) | |
| 666 (forward-line 1)) | |
| 667 (setq files (nreverse files)) | |
| 668 ;; let the function output information in the buffer | |
| 669 (erase-buffer)) | |
| 670 (display-buffer buffer) | |
| 671 ;; apply the function | |
| 672 (save-excursion | |
| 673 (set-buffer buffer) | |
| 674 (while files | |
| 675 (apply func (car files) args) | |
| 676 (setq files (cdr files))) | |
| 677 buffer))) | |
| 678 | |
| 679 (defun sc-get-version-in-temp-file (file revision) | |
| 680 "For the given FILE, retrieve a copy of the version with given REVISION. | |
| 681 The text is retrieved into a tempfile. Return the tempfile name." | |
| 682 (let* ((oldversion | |
| 683 (make-temp-name | |
| 684 (concat (or (ccase-protect-expanded-name revision) "current") | |
| 685 "-" | |
| 686 (file-name-nondirectory file) | |
| 687 "-"))) | |
| 688 (vbuf (get-buffer-create oldversion))) | |
| 689 (sc-get-version file vbuf revision) | |
| 690 (save-excursion | |
| 691 (set-buffer vbuf) | |
| 692 (write-region (point-min) (point-max) oldversion t 0)) | |
| 693 (kill-buffer vbuf) | |
| 694 (sc-chmod "-w" oldversion) | |
| 695 oldversion)) | |
| 696 | |
| 697 ;; Functions used to get directory level information | |
| 698 | |
| 699 (defun sc-insert-file-lock-info (file lock-info) | |
| 700 (insert (car lock-info) ":" (car (cdr lock-info))) | |
| 701 (indent-to-column 16 1) | |
| 702 (insert (file-name-nondirectory file) "\n")) | |
| 703 | |
| 704 (defun sc-list-file-if-locked (file &optional arg) | |
| 705 "List all files underneath the current directory matching a prefix type." | |
| 706 (let ((lock-info (sc-lock-info file))) | |
| 707 (if (and lock-info | |
| 708 (car lock-info) | |
| 709 (or (null arg) (equal arg (car lock-info)))) | |
| 710 (progn | |
| 711 (sc-insert-file-lock-info file lock-info) | |
| 712 (sit-for 0))))) | |
| 713 | |
| 714 (defun sc-list-file (file) | |
| 715 (let ((lock-info (sc-lock-info file))) | |
| 716 (cond ((eq lock-info 'na) | |
| 717 (indent-to-column 16 1) | |
| 718 (insert (file-name-nondirectory file) "\n")) | |
| 719 ((car lock-info) | |
| 720 (sc-insert-file-lock-info file lock-info)) | |
| 721 ((sc-new-revision-p file) | |
| 722 (insert "needs update") | |
| 723 (indent-to-column 16 1) | |
| 724 (insert (file-name-nondirectory file) "\n")) | |
| 725 (t | |
| 726 (indent-to-column 16 1) | |
| 727 (insert (file-name-nondirectory file) "\n"))) | |
| 728 (sit-for 0))) | |
| 729 | |
| 730 ;;; Function to update one file from the archive | |
| 731 (defun sc-update-file (file) | |
| 732 "get the latest version of the file if a new one was checked-in" | |
| 733 (if (sc-new-revision-p file) | |
| 734 (let ((file-name (file-name-nondirectory file))) | |
| 735 ;; get the latest copy | |
| 736 (rename-file (sc-get-version-in-temp-file file nil) file t) | |
| 737 (let ((b (get-file-buffer file))) | |
| 738 (if b | |
| 739 (save-excursion | |
| 740 (set-buffer b) | |
| 741 (revert-buffer nil t) | |
| 742 (sc-mode-line)))) | |
| 743 ;; show the file was updated | |
| 744 (insert "updated") | |
| 745 (indent-to-column 16 1) | |
| 746 (insert file-name "\n") | |
| 747 (sit-for 0)))) | |
| 748 | |
| 749 ;; Set up key bindings for use while editing log messages | |
| 750 | |
| 751 (if sc-log-entry-keymap | |
| 752 nil | |
| 753 (setq sc-log-entry-keymap (make-sparse-keymap)) | |
| 754 (define-key sc-log-entry-keymap "\C-ci" 'sc-insert-last-log) | |
| 755 (define-key sc-log-entry-keymap "\C-c\C-i" 'sc-insert-last-log) | |
| 756 (define-key sc-log-entry-keymap "\C-ca" 'sc-abort-check-in) | |
| 757 (define-key sc-log-entry-keymap "\C-c\C-a" 'sc-abort-check-in) | |
| 758 (define-key sc-log-entry-keymap "\C-c\C-c" 'sc-log-exit) | |
| 759 (define-key sc-log-entry-keymap "\C-x\C-s" 'sc-log-exit)) | |
| 760 | |
| 761 (defvar sc-mode-hook nil | |
| 762 "*Function or functions to run on entry to sc-mode.") | |
| 763 | |
| 764 (defvar sc-mode () | |
| 765 "The currently active source control mode. Use M-x sc-mode to set it") | |
| 766 | |
| 767 ;;;###autoload | |
| 768 (defun sc-mode (system) | |
| 769 "Toggle sc-mode. | |
| 770 SYSTEM can be sccs, rcs or cvs. | |
| 771 Cvs requires the pcl-cvs package. | |
| 772 | |
| 773 The following commands are available | |
| 774 \\[sc-next-operation] perform next logical source control operation on current file | |
| 775 \\[sc-show-changes] compare the version being edited with an older one | |
| 776 \\[sc-version-diff-file] compare two older versions of a file | |
| 777 \\[sc-show-history] display change history of current file | |
| 778 \\[sc-visit-previous-revision] display an older revision of current file | |
| 779 \\[sc-revert-file] revert buffer to last checked-in version | |
| 780 \\[sc-list-all-locked-files] show all files locked in current directory | |
| 781 \\[sc-list-locked-files] show all files locked by you in current directory | |
| 782 \\[sc-list-registered-files] show all files under source control in current directory | |
| 783 \\[sc-update-directory] get fresh copies of files checked-in by others in current directory | |
| 784 \\[sc-rename-file] rename the current file and its source control file | |
| 785 | |
| 786 | |
| 787 While you are entering a change log message for a check in, sc-log-entry-mode | |
| 788 will be in effect. | |
| 789 | |
| 790 Global user options: | |
| 791 sc-diff-command A list consisting of the command and flags | |
| 792 to be used for generating context diffs. | |
| 793 sc-mode-expert suppresses some conformation prompts, | |
| 794 notably for delta aborts and file saves. | |
| 795 sc-max-log-size specifies the maximum allowable size | |
| 796 of a log message plus one. | |
| 797 | |
| 798 | |
| 799 When using SCCS you have additional commands and options | |
| 800 | |
| 801 \\[sccs-insert-headers] insert source control headers in current file | |
| 802 | |
| 803 When you generate headers into a buffer using \\[sccs-insert-headers], | |
| 804 the value of sc-insert-headers-hook is called before insertion. If the | |
| 805 file is recognized a C or Lisp source, sc-insert-c-header-hook or | |
| 806 sc-insert-lisp-header-hook is called after insertion respectively. | |
| 807 | |
| 808 sccs-headers-wanted which %-keywords to insert when adding | |
| 809 headers with C-c h | |
| 810 sccs-insert-static if non-nil, keywords inserted in C files | |
| 811 get stuffed in a static string area so that | |
| 812 what(1) can see them in the compiled object code. | |
| 813 | |
| 814 When using CVS you have additional commands | |
| 815 | |
| 816 \\[sc-cvs-update-directory] update the current directory using pcl-cvs | |
| 817 \\[sc-cvs-file-status] show the CVS status of current file | |
| 818 " | |
| 819 (interactive | |
| 820 (if sc-mode | |
| 821 '(()) | |
| 822 (list | |
| 823 (intern | |
| 824 (read-string "Turn on source control mode on for: " "SCCS"))))) | |
| 825 (cond ((eq system ()) | |
| 826 (remove-hook 'find-file-hooks 'sc-mode-line) | |
| 827 (delete-menu-item (list sc-generic-name)) | |
| 828 (remove-hook 'activate-menubar-hook 'sc-sensitize-menu) | |
| 829 (setq sc-mode ())) | |
| 830 (sc-mode | |
| 831 (sc-mode ()) | |
| 832 (sc-mode system)) | |
| 833 (t | |
| 834 (setq system (intern (upcase (symbol-name system)))) | |
| 835 (let ((f (intern (format "sc-set-%s-mode" system)))) | |
| 836 (if (not (fboundp f)) | |
| 837 (error | |
| 838 "No source control interface for \"%s\". \ | |
| 839 Please use SCCS, RCS, CVS, or Atria." | |
| 840 system) | |
| 841 (funcall f) | |
| 842 (add-hook 'find-file-hooks 'sc-mode-line) | |
| 843 (add-submenu '() (cons sc-generic-name sc-menu)) | |
| 844 (add-hook 'activate-menubar-hook 'sc-sensitize-menu) | |
| 845 (run-hooks 'sc-mode-hook) | |
| 846 (setq sc-mode system)))))) | |
| 847 | |
| 848 (defun sc-log-entry-mode () | |
| 849 "Major mode for editing log message. | |
| 850 | |
| 851 These bindings are available when entering the log message | |
| 852 \\[sc-log-exit] proceed with check in, ending log message entry | |
| 853 \\[sc-insert-last-log] insert log message from last check-in | |
| 854 \\[sc-abort-check-in] abort this check-in | |
| 855 | |
| 856 Entry to the change-log submode calls the value of text-mode-hook, then | |
| 857 the value sc-log-entry-mode-hook. | |
| 858 " | |
| 859 (interactive) | |
| 860 (set-syntax-table text-mode-syntax-table) | |
| 861 (use-local-map sc-log-entry-keymap) | |
| 862 (setq local-abbrev-table text-mode-abbrev-table) | |
| 863 (setq major-mode 'sc-log-entry-mode) | |
| 864 (setq mode-name "Source Control Change Log Entry") | |
| 865 (run-hooks 'text-mode-hook 'sc-log-entry-mode-hook)) | |
| 866 | |
| 867 | |
| 868 | |
| 869 ;;; SCCS specific part | |
| 870 | |
| 871 ;; Find a reasonable default for the SCCS bin directory | |
| 872 (defvar sccs-bin-directory | |
| 873 (cond ((file-executable-p "/usr/sccs/unget") "/usr/sccs") | |
| 874 ((file-executable-p "/usr/bin/unget") "/usr/bin") | |
| 875 ((file-directory-p "/usr/sccs") "/usr/sccs") | |
| 876 ((file-directory-p "/usr/bin/sccs") "/usr/bin/sccs") | |
| 877 (t "/usr/bin")) | |
| 878 "*Directory where to find the sccs executables") | |
| 879 | |
| 880 (defvar sccs-headers-wanted '("\%\W\%") | |
| 881 "*SCCS header keywords to be inserted when sccs-insert-header is executed.") | |
| 882 | |
| 883 (defvar sccs-insert-static t | |
| 884 "*Insert a static character string when inserting source control headers in C mode. | |
| 885 Only relevant for the SCCS mode.") | |
| 886 | |
| 887 ;; Vars the user doesn't need to know about. | |
| 888 | |
| 889 (defvar sccs-log-entry-mode nil) | |
| 890 (defvar sccs-current-major-version nil) | |
| 891 | |
| 892 ;; Some helper functions | |
| 893 | |
| 894 (defun sccs-name (file &optional letter) | |
| 895 "Return the sccs-file name corresponding to a given file." | |
| 896 (if (null file) | |
| 897 () | |
| 898 (let ((expanded-file (expand-file-name file))) | |
| 899 (format "%sSCCS/%s.%s" | |
| 900 (concat (file-name-directory expanded-file)) | |
| 901 (or letter "s") | |
| 902 (concat (file-name-nondirectory expanded-file)))))) | |
| 903 | |
| 904 (defun sccs-lock-info (file) | |
| 905 "Lock-info method for SCCS. See sc-generic-lock-info" | |
| 906 (let ((sccs-file (sccs-name file "s")) | |
| 907 (lock-file (sccs-name file "p"))) | |
| 908 (cond ((or (null file) (not (file-exists-p sccs-file))) | |
| 909 ()) | |
| 910 ((not (file-exists-p lock-file)) | |
| 911 (list () ())) | |
| 912 (t | |
| 913 (save-excursion | |
| 914 (set-buffer (get-buffer-create "*SCCS tmp*")) | |
| 915 (insert-file lock-file) | |
| 916 (while (search-forward " " () t) | |
| 917 (replace-match "\n" () t)) | |
| 918 (goto-char (point-min)) | |
| 919 (forward-line 1) | |
| 920 (let ((revision | |
| 921 (buffer-substring (point) (progn (end-of-line) (point)))) | |
| 922 (name | |
| 923 (progn (forward-line 1) | |
| 924 (buffer-substring (point) | |
| 925 (progn (end-of-line) (point)))))) | |
| 926 (kill-buffer (current-buffer)) | |
| 927 (list name revision))))))) | |
| 928 | |
| 929 | |
| 930 (defun sccs-do-command (buffer command file &rest flags) | |
| 931 "Execute an SCCS command, notifying the user and checking for errors." | |
| 932 (let ((exec-path (cons sccs-bin-directory exec-path))) | |
| 933 (apply 'sc-do-command buffer command command file (sccs-name file) flags))) | |
| 934 | |
| 935 (defun sccs-admin (file sid) | |
| 936 "Checks a file into sccs. | |
| 937 FILE is the unmodified name of the file. SID should be the base-level sid to | |
| 938 check it in under." | |
| 939 ;; give a change to save the file if it's modified | |
| 940 (if (and (buffer-modified-p) | |
| 941 (y-or-n-p (format "%s has been modified. Write it out? " | |
| 942 (buffer-name)))) | |
| 943 (save-buffer)) | |
| 944 (sccs-do-command "*SCCS*" "admin" file | |
| 945 (concat "-i" file) (concat "-r" sid)) | |
| 946 (sc-chmod "-w" file) | |
| 947 ;; expand SCCS headers | |
| 948 (sccs-check-out file nil)) | |
| 949 | |
| 950 (defun sccs-register (file revision) | |
| 951 (sccs-load-vars) | |
| 952 (if (and (not (file-exists-p "SCCS")) | |
| 953 (y-or-n-p "Directory SCCS does not exist, create it?")) | |
| 954 (make-directory "SCCS")) | |
| 955 (sccs-admin file | |
| 956 (cond | |
| 957 (revision revision) | |
| 958 ((error-occurred (load-file "SCCS/emacs-vars.el")) "1") | |
| 959 (t sccs-current-major-version)))) | |
| 960 | |
| 961 (defun sccs-check-out (file lockp) | |
| 962 "Retrieve a copy of the latest version of the given file." | |
| 963 (sccs-do-command "*SCCS*" "get" file (if lockp "-e"))) | |
| 964 | |
| 965 (defun sccs-get-version (file buffer revision) | |
| 966 (sccs-do-command buffer "get" file | |
| 967 (and revision (concat "-r" revision)) | |
| 968 "-p" "-s")) | |
| 969 | |
| 970 (defun sccs-check-in (file revision comment) | |
| 971 "Check-in a given version of the given file with the given comment." | |
| 972 (sccs-do-command "*SCCS*" "delta" file "-n" | |
| 973 (format "-r%s" revision) | |
| 974 (format "-y%s" comment)) | |
| 975 (sc-chmod "-w" file) | |
| 976 ;; sccs-delta already turned off write-privileges on the | |
| 977 ;; file, let's not re-fetch it unless there's something | |
| 978 ;; in it that get would expand | |
| 979 (save-excursion | |
| 980 (let ((buffer (get-file-buffer file))) | |
| 981 (if buffer | |
| 982 (progn | |
| 983 (set-buffer buffer) | |
| 984 (sccs-check-out file nil)))))) | |
| 985 | |
| 986 (defun sccs-history (file) | |
| 987 (sccs-do-command (current-buffer) "prs" file)) | |
| 988 | |
| 989 ;; There has *got* to be a better way to do this... | |
| 990 | |
| 991 (defun sccs-save-vars (sid) | |
| 992 (save-excursion | |
| 993 (find-file "SCCS/emacs-vars.el") | |
| 994 (erase-buffer) | |
| 995 (insert "(setq sccs-current-major-version \"" sid "\")") | |
| 996 (basic-save-buffer))) | |
| 997 | |
| 998 (defun sccs-load-vars () | |
| 999 (if (error-occurred (load-file "SCCS/emacs-vars.el")) | |
| 1000 (setq sccs-current-major-version "1"))) | |
| 1001 | |
| 1002 ;; SCCS header insertion code | |
| 1003 | |
| 1004 (defun sccs-insert-headers () | |
| 1005 "*Insert headers for use with the Source Code Control System. | |
| 1006 Headers desired are inserted at the start of the buffer, and are pulled from | |
| 1007 the variable sccs-headers-wanted" | |
| 1008 (interactive) | |
| 1009 (save-excursion | |
| 1010 (save-restriction | |
| 1011 (widen) | |
| 1012 (if (or (not (sccs-check-headers)) | |
| 1013 (y-or-n-p "SCCS headers already exist. Insert another set?")) | |
| 1014 (progn | |
| 1015 (goto-char (point-min)) | |
| 1016 (run-hooks 'sccs-insert-headers-hook) | |
| 1017 (cond ((eq major-mode 'c-mode) (sccs-insert-c-header)) | |
| 1018 ((eq major-mode 'lisp-mode) (sccs-insert-lisp-header)) | |
| 1019 ((eq major-mode 'emacs-lisp-mode) (sccs-insert-lisp-header)) | |
| 1020 ((eq major-mode 'scheme-mode) (sccs-insert-lisp-header)) | |
| 1021 ((eq major-mode 'nroff-mode) (sccs-insert-nroff-header)) | |
| 1022 ((eq major-mode 'plain-tex-mode) (sccs-insert-tex-header)) | |
| 1023 ((eq major-mode 'texinfo-mode) (sccs-insert-texinfo-header)) | |
| 1024 (t (sccs-insert-generic-header)))))))) | |
| 1025 | |
| 1026 | |
| 1027 | |
| 1028 (defun sccs-insert-c-header () | |
| 1029 (insert "/*\n") | |
| 1030 (mapcar '(lambda (s) | |
| 1031 (insert " *\t" s "\n")) | |
| 1032 sccs-headers-wanted) | |
| 1033 (insert " */\n\n") | |
| 1034 (if (and sccs-insert-static | |
| 1035 (not (string-match "\\.h$" buffer-file-name))) | |
| 1036 (progn | |
| 1037 (insert "#ifndef lint\n" | |
| 1038 "static char *sccsid") | |
| 1039 ;; (setq st (point)) | |
| 1040 ;; (insert (file-name-nondirectory buffer-file-name)) | |
| 1041 ;; (setq en (point)) | |
| 1042 ;; (subst-char-in-region st en ?. ?_) | |
| 1043 (insert " = \"\%\W\%\";\n" | |
| 1044 "#endif /* lint */\n\n"))) | |
| 1045 (run-hooks 'sccs-insert-c-header-hook)) | |
| 1046 | |
| 1047 (defun sccs-insert-lisp-header () | |
| 1048 (mapcar '(lambda (s) | |
| 1049 (insert ";;;\t" s "\n")) | |
| 1050 sccs-headers-wanted) | |
| 1051 (insert "\n") | |
| 1052 (run-hooks 'sccs-insert-lisp-header-hook)) | |
| 1053 | |
| 1054 (defun sccs-insert-nroff-header () | |
| 1055 (mapcar '(lambda (s) | |
| 1056 (insert ".\\\"\t" s "\n")) | |
| 1057 sccs-headers-wanted) | |
| 1058 (insert "\n") | |
| 1059 (run-hooks 'sccs-insert-nroff-header-hook)) | |
| 1060 | |
| 1061 (defun sccs-insert-tex-header () | |
| 1062 (mapcar '(lambda (s) | |
| 1063 (insert "%%\t" s "\n")) | |
| 1064 sccs-headers-wanted) | |
| 1065 (insert "\n") | |
| 1066 (run-hooks 'sccs-insert-tex-header-hook)) | |
| 1067 | |
| 1068 (defun sccs-insert-texinfo-header () | |
| 1069 (mapcar '(lambda (s) | |
| 1070 (insert "@comment\t" s "\n")) | |
| 1071 sccs-headers-wanted) | |
| 1072 (insert "\n") | |
| 1073 (run-hooks 'sccs-insert-texinfo-header-hook)) | |
| 1074 | |
| 1075 (defun sccs-insert-generic-header () | |
| 1076 (let* ((comment-start-sccs (or comment-start "#")) | |
| 1077 (comment-end-sccs (or comment-end "")) | |
| 1078 (dont-insert-nl-p (string-match "\n" comment-end-sccs))) | |
| 1079 (mapcar '(lambda (s) | |
| 1080 (insert comment-start-sccs "\t" s "" | |
| 1081 comment-end-sccs (if dont-insert-nl-p "" "\n"))) | |
| 1082 sccs-headers-wanted) | |
| 1083 (insert comment-start-sccs comment-end-sccs (if dont-insert-nl-p "" "\n")))) | |
| 1084 | |
| 1085 (defun sccs-check-headers () | |
| 1086 "Check if the current file has any SCCS headers in it." | |
| 1087 (save-excursion | |
| 1088 (goto-char (point-min)) | |
| 1089 (let ((case-fold-search ())) | |
| 1090 (re-search-forward "%[MIRLBSDHTEGUYFPQCZWA]%" (point-max) t)))) | |
| 1091 | |
| 1092 (defun sccs-tree-list () | |
| 1093 "List all the registered files in the current directory" | |
| 1094 (call-process "/bin/sh" () t () "-c" | |
| 1095 (concat "/bin/ls -1 " default-directory "SCCS/s.*")) | |
| 1096 (goto-char (point-min)) | |
| 1097 (while (search-forward "SCCS/s." () t) | |
| 1098 (replace-match "" () t))) | |
| 1099 | |
| 1100 (defun sccs-new-revision-p (file) | |
| 1101 "True if the SCCS archive is more recent than the file itself" | |
| 1102 (file-newer-than-file-p (sccs-name file) file)) | |
| 1103 | |
| 1104 (defun sccs-revert (file) | |
| 1105 "Cancel a check-out and get a fresh copy of the file" | |
| 1106 (delete-file (sccs-name file "p")) | |
| 1107 (delete-file file) | |
| 1108 (sccs-do-command "*SCCS*" "get" file "-s")) | |
| 1109 | |
| 1110 (defun sccs-rename (old new) | |
| 1111 "Rename the SCCS archives for OLD to NEW" | |
| 1112 (if (file-exists-p (sccs-name old "p")) | |
| 1113 (rename-file (sccs-name old "p") (sccs-name new "p") t)) | |
| 1114 (if (file-exists-p (sccs-name old "s")) | |
| 1115 (rename-file (sccs-name old "s") (sccs-name new "s") t))) | |
| 1116 | |
| 1117 | |
| 1118 ;;; RCS specific part | |
| 1119 | |
| 1120 ;; Some helper functions | |
| 1121 | |
| 1122 (defun rcs-name (file) | |
| 1123 "Return the rcs-file corresponding to a given file." | |
| 1124 (if (null file) | |
| 1125 () | |
| 1126 (let* ((name (expand-file-name file)) | |
| 1127 (rcs-file (concat name ",v"))) | |
| 1128 (if (and (not (file-exists-p rcs-file)) | |
| 1129 (file-exists-p (concat (file-name-directory name) "RCS"))) | |
| 1130 (setq rcs-file | |
| 1131 (format "%sRCS/%s,v" (file-name-directory name) | |
| 1132 (file-name-nondirectory name)))) | |
| 1133 rcs-file))) | |
| 1134 | |
| 1135 (defun rcs-lock-info (file) | |
| 1136 "Lock-info method for RCS. See sc-generic-lock-info" | |
| 1137 (let ((rcs-file (rcs-name file)) | |
| 1138 locks-regexp) | |
| 1139 (if (or (null rcs-file) (not (file-exists-p rcs-file))) | |
| 1140 () | |
| 1141 (save-excursion | |
| 1142 (set-buffer (get-buffer-create "*RCS tmp*")) | |
| 1143 (erase-buffer) | |
| 1144 (call-process "rlog" () t () "-L" "-h" rcs-file) | |
| 1145 (goto-char (point-min)) | |
| 1146 (if (looking-at "\n.*Working file") | |
| 1147 ;; RCS 4.x | |
| 1148 (setq locks-regexp "^locks:") | |
| 1149 ;; RCS 5.x | |
| 1150 (setq locks-regexp "^locks:.*$\n")) | |
| 1151 (if (not (re-search-forward locks-regexp () t)) | |
| 1152 (list () ()) | |
| 1153 (if (not (looking-at (concat "[\t ]*\\([^:]*\\): \\([0-9\\.]*\\)"))) | |
| 1154 (list () ()) | |
| 1155 (list (buffer-substring (match-beginning 1) (match-end 1)) | |
| 1156 (buffer-substring (match-beginning 2) (match-end 2))))))))) | |
| 1157 | |
| 1158 | |
| 1159 (defun rcs-register (file revision) | |
| 1160 (if (and (not (file-exists-p "RCS")) | |
| 1161 (y-or-n-p "Directory RCS does not exist, create it?")) | |
| 1162 (make-directory "RCS")) | |
| 1163 (sc-do-command "*RCS*" "ci" "ci" file (rcs-name file) "-u")) | |
| 1164 | |
| 1165 (defun rcs-check-out (file lockp) | |
| 1166 (sc-do-command "*RCS*" "co" "co" file (rcs-name file) (if lockp "-l"))) | |
| 1167 | |
| 1168 (defun rcs-get-version (file buffer revision) | |
| 1169 (sc-do-command buffer "co" "co" file (rcs-name file) | |
| 1170 (if revision (concat "-p" revision) "-p") | |
| 1171 "-q")) | |
| 1172 | |
| 1173 (defun rcs-check-in (file revision comment) | |
| 1174 "Check-in a given version of the given file with the given comment." | |
| 1175 (sc-do-command "*RCS*" "ci" "ci" file (rcs-name file) "-f" | |
| 1176 (format "-m%s" comment) | |
| 1177 (if (equal revision (sc-locked-revision file)) | |
| 1178 "-u" | |
| 1179 (format "-u%s" revision)))) | |
| 1180 | |
| 1181 (defun rcs-history (file) | |
| 1182 (sc-do-command (current-buffer) "rlog" "rlog" file (rcs-name file))) | |
| 1183 | |
| 1184 (defun rcs-tree-list () | |
| 1185 "List all the registered files in the current directory" | |
| 1186 (call-process "/bin/sh" () t () "-c" | |
| 1187 (concat "/bin/ls -1 " default-directory "RCS/*,v")) | |
| 1188 (call-process "/bin/sh" () t () "-c" | |
| 1189 (concat "/bin/ls -1 " default-directory "*,v")) | |
| 1190 (goto-char (point-min)) | |
| 1191 (while (search-forward "RCS/" () t) | |
| 1192 (replace-match "" () t)) | |
| 1193 (goto-char (point-min)) | |
| 1194 (while (search-forward ",v" () t) | |
| 1195 (replace-match "" () t))) | |
| 1196 | |
| 1197 (defun rcs-new-revision-p (file) | |
| 1198 "True if the archive is more recent than the file itself" | |
| 1199 (file-newer-than-file-p (rcs-name file) file)) | |
| 1200 | |
| 1201 (defun rcs-revert (file) | |
| 1202 "Cancel a check-out and get a fresh copy of the file" | |
| 1203 (sc-do-command "*RCS*" "rcs" "rcs" file (rcs-name file) "-u") | |
| 1204 (delete-file file) | |
| 1205 (sc-do-command "*RCS*" "co" "co" file (rcs-name file))) | |
| 1206 | |
| 1207 (defun rcs-rename (old new) | |
| 1208 "Rename the archives for OLD to NEW" | |
| 1209 (if (file-exists-p (rcs-name old)) | |
| 1210 (rename-file (rcs-name old) (rcs-name new) t))) | |
| 1211 | |
| 1212 | |
| 1213 ;;; CVS specific part | |
| 1214 | |
| 1215 ;;; As we rely on pcl-cvs for the directory level functions the menu is | |
| 1216 ;;; much shorter in CVS mode | |
| 1217 | |
| 1218 | |
| 1219 (defun cvs-lock-info (file) | |
| 1220 "Lock-info method for CVS, different from RCS and SCCS modes. | |
| 1221 File are never locked in CVS." | |
| 1222 (list () ())) | |
| 1223 | |
| 1224 (defun cvs-register (file revision) | |
| 1225 (sc-do-command "*CVS*" "cvs add" cvs-program file | |
| 1226 (file-name-nondirectory file) | |
| 1227 "add" "-mInitial revision")) | |
| 1228 | |
| 1229 (defun cvs-check-out (file lockp) | |
| 1230 ) | |
| 1231 | |
| 1232 (defun cvs-get-version (file buffer revision) | |
| 1233 (sc-do-command buffer "cvs update" cvs-program file file "update" | |
| 1234 (if revision (concat "-r" revision)) | |
| 1235 "-p" "-q")) | |
| 1236 | |
| 1237 (defun cvs-check-in (file revision comment) | |
| 1238 "Check-in a given version of the given file with the given comment." | |
| 1239 (sc-do-command "*CVS*" "cvs commit" cvs-program file file "commit" | |
| 1240 (and revision (format "-r%s" revision)) | |
| 1241 (format "-m%s" comment))) | |
| 1242 | |
| 1243 (defun cvs-history (file) | |
| 1244 (sc-do-command (current-buffer) "cvs log" cvs-program file file "log")) | |
| 1245 | |
| 1246 (defun cvs-revert (file) | |
| 1247 "Cancel a check-out and get a fresh copy of the file" | |
| 1248 (delete-file file) | |
| 1249 (sc-do-command "*CVS*" "cvs update" cvs-program file file "update")) | |
| 1250 | |
| 1251 (defun sc-cvs-update-directory () | |
| 1252 "Update the current directory by calling cvs-update from pcl-cvs" | |
| 1253 (interactive) | |
| 1254 (cvs-update default-directory)) | |
| 1255 | |
| 1256 (defun sc-cvs-file-status () | |
| 1257 "Show the CVS status of the current file" | |
| 1258 (interactive) | |
| 1259 (if (not buffer-file-name) | |
| 1260 (error "There is no file associated with buffer %s" (buffer-name))) | |
| 1261 (let ((file buffer-file-name)) | |
| 1262 (sc-do-command "*CVS*" "cvs status" cvs-program file file "status" "-v")) | |
| 1263 (save-excursion | |
| 1264 (set-buffer "*CVS*") | |
| 1265 (goto-char (point-min))) | |
| 1266 (display-buffer "*CVS*")) | |
| 1267 | |
| 1268 | |
| 1269 ;;; ClearCase specific part | |
| 1270 | |
| 1271 (defun ccase-is-registered-3 (fod) | |
| 1272 (if (or (not fod) | |
| 1273 (not (file-readable-p fod))) | |
| 1274 'na | |
| 1275 (let ((dirs sc-ccase-mfs-prefixes) | |
| 1276 (f nil) | |
| 1277 (file (expand-file-name fod))) | |
| 1278 (while (and (null f) dirs) | |
| 1279 (if (string-match (car dirs) file) | |
| 1280 (setq f t) | |
| 1281 (setq dirs (cdr dirs)))) | |
| 1282 (if (null f) | |
| 1283 'na | |
| 1284 (sc-do-command "*CCase*" "describe" "cleartool" fod fod "describe") | |
| 1285 (save-excursion | |
| 1286 (set-buffer "*CCase*") | |
| 1287 (let ((s (buffer-string))) | |
| 1288 (cond | |
| 1289 ((string-match "@@" s) t) | |
| 1290 ((string-match "^Unix" s) 'na) | |
| 1291 (t nil) | |
| 1292 ))))))) | |
| 1293 | |
| 1294 (defun ccase-is-registered (fod) | |
| 1295 (eq (ccase-is-registered-3 fod) t)) | |
| 1296 | |
| 1297 (defun ccase-lock-info (file) | |
| 1298 (let ((cc (ccase-is-registered-3 file)) | |
| 1299 s) | |
| 1300 (if (eq cc 't) | |
| 1301 (progn | |
| 1302 (save-excursion | |
| 1303 (set-buffer "*CCase*") | |
| 1304 (setq s (buffer-string))) | |
| 1305 (if (string-match "@@[^\n]*CHECKEDOUT\" from \\([^ ]*\\)[^\n]*\n[^\n]* by \\([^(\n]*\\) (" s) | |
| 1306 (list | |
| 1307 (substring s (match-beginning 1) (match-end 1)) | |
| 1308 (substring s (match-beginning 2) (match-end 2))) | |
| 1309 (list nil nil))) | |
| 1310 cc))) | |
| 1311 | |
| 1312 (defun ccase-maybe-comment (tag) | |
| 1313 (if (memq tag sc-ccase-comment-on) | |
| 1314 (sc-enter-comment))) | |
| 1315 | |
| 1316 (defun ccase-register (file revision) | |
| 1317 "Registers the file. We don't support the revision argument. | |
| 1318 Also, we have to checkout the directory first." | |
| 1319 ;; probably need proper error handling to catch the | |
| 1320 ;; cases where we co the directory, but don't get to | |
| 1321 ;; ci it back (want to uco in this case) | |
| 1322 (let ((dpath (file-name-directory file))) | |
| 1323 (if (not (ccase-is-registered dpath)) | |
| 1324 (error "Cannot register file outside of VOB") | |
| 1325 (sc-do-command "*CCase*" "co - dir" "cleartool" dpath dpath "co") | |
| 1326 (sc-do-command "*CCase*" "register" "cleartool" file file "mkelem") | |
| 1327 (sc-do-command "*CCase*" "ci - dir" "cleartool" dpath dpath "ci")))) | |
| 1328 | |
| 1329 (defun ccase-check-out (file lockp) | |
| 1330 "Checks out the latest version of FILE. | |
| 1331 If LOCKP is not NIL, FILE is also locked." | |
| 1332 (let ((comment (ccase-maybe-comment 'checkout))) | |
| 1333 (sc-do-command "*CCase*" "co" "cleartool" file file "co" | |
| 1334 (if comment "-c" "-nc") | |
| 1335 (if comment comment) | |
| 1336 ;; this locking does not correspond to what we actually want. It's a | |
| 1337 ;; hack from the days when this was SCCS-only | |
| 1338 (if (ccase-reserve-p) "-res" "-unr")) | |
| 1339 )) | |
| 1340 | |
| 1341 (defun ccase-reserve-p () | |
| 1342 "Determine whether the user wants a reserved or unreserved checkout" | |
| 1343 (cond | |
| 1344 ((eq sc-ccase-reserve t) t) | |
| 1345 ((eq sc-ccase-reserve nil) nil) | |
| 1346 (t (y-or-n-p "Reserve Checkout? ")))) | |
| 1347 | |
| 1348 (defun ccase-get-version (file buffer revision) | |
| 1349 "Insert a previous revison of FILE in BUFFER. | |
| 1350 REVISION is the revision number requested." | |
| 1351 (save-excursion | |
| 1352 (set-buffer buffer) | |
| 1353 (delete-region (point-min) (point-max)) | |
| 1354 (insert-file-contents (concat file "@@/" revision))) | |
| 1355 ) | |
| 1356 | |
| 1357 (defun ccase-check-in (file revision message) | |
| 1358 "Check in FILE with revision REVISION. | |
| 1359 MESSAGE is a string describing the changes." | |
| 1360 ;; we ignore revision since we can't use it | |
| 1361 (sc-do-command "*CCase*" "ci" "cleartool" file file "ci" "-c" message (if sc-mode-expert "-ide")) | |
| 1362 ) | |
| 1363 | |
| 1364 (defun ccase-history (file) | |
| 1365 "Insert the edit history of FILE in the current buffer." | |
| 1366 (sc-do-command (buffer-name) "history" "cleartool" file file "lsh") | |
| 1367 ) | |
| 1368 | |
| 1369 (defun ccase-tree-list () | |
| 1370 "List in the current buffer the files registered in the source control system" | |
| 1371 ;;; This isn't going to fly as a practicality. We abstract everything out. | |
| 1372 ;; (sc-do-command (buffer-name) "listing" "cleartool" (default-directory) (default-directory) "ls" "-r" "-short" "-vis" "-nxname") | |
| 1373 ) | |
| 1374 | |
| 1375 (defun ccase-new-revision-p (file) | |
| 1376 "True if a new revision of FILE was checked in since we last got a copy of it" | |
| 1377 (save-excursion | |
| 1378 (let (newfile res br1 br2) | |
| 1379 (sc-do-command "*CCase*" "Describe" "cleartool" file file "des") | |
| 1380 (set-buffer "*CCase*") | |
| 1381 (goto-char (point-min)) | |
| 1382 (if (setq pos (search-forward-regexp "@@\\([^ \"]*\\)CHECKEDOUT\" from \\([^ ]*\\) (\\([a-z]*\\))" nil t)) | |
| 1383 ;; (if (setq pos (search-forward-regexp "@@\\([^ \"]*\\)CHECKEDOUT\"" nil t)) | |
| 1384 (progn | |
| 1385 (setq res (buffer-substring (match-beginning 3) (match-end 3))) | |
| 1386 (if (equal res "unreserved") | |
| 1387 (progn | |
| 1388 (setq newfile (concat file "@@" | |
| 1389 (buffer-substring (match-beginning 1) | |
| 1390 (match-end 1)) | |
| 1391 "LATEST")) | |
| 1392 (setq br1 (buffer-substring (match-beginning 2) (match-end 2))) | |
| 1393 (sc-do-command "*CCase*" "Describe" "cleartool" file newfile | |
| 1394 "des") | |
| 1395 (search-forward-regexp "@@\\([^ \"]*\\)" nil t) | |
| 1396 (setq br2 (buffer-substring (match-beginning 1) (match-end 1))) | |
| 1397 (not (equal br1 br2))) | |
| 1398 nil)) | |
| 1399 (error "%s not currently checked out" file))))) | |
| 1400 | |
| 1401 (defun ccase-revert (file) | |
| 1402 "Cancel a check out of FILE and get back the latest checked in version" | |
| 1403 (sc-do-command "*CCase*" "uco" "cleartool" file file "unco") | |
| 1404 ) | |
| 1405 | |
| 1406 (defun ccase-rename (old new) | |
| 1407 "Rename the source control archives for OLD to NEW" | |
| 1408 (let ((dpath (file-name-directory old)) | |
| 1409 (comment (ccase-maybe-comment 'rename))) | |
| 1410 (if (not (ccase-is-registered dpath)) | |
| 1411 (error "Cannot rename file outside of VOB") | |
| 1412 (sc-do-command "*CCase*" "co - dir" "cleartool" dpath dpath "co" | |
| 1413 (if comment "-c" "-nc") | |
| 1414 (if comment comment)) | |
| 1415 (sc-do-command "*CCase*" "mv" "cleartool" new new "mv" | |
| 1416 (if comment "-c" "-nc") | |
| 1417 (if comment comment) | |
| 1418 old) | |
| 1419 (sc-do-command "*CCase*" "ci - dir" "cleartool" dpath dpath "ci" | |
| 1420 (if comment "-c" "-nc") | |
| 1421 (if comment comment))))) | |
| 1422 | |
| 1423 (defun sc-ccase-checkout-dir () | |
| 1424 "Checkout the directory this file is in" | |
| 1425 (interactive) | |
| 1426 (let ((dpath default-directory) | |
| 1427 (comment (ccase-maybe-comment 'checkout-dir))) | |
| 1428 (if (not (ccase-is-registered dpath)) | |
| 1429 (error "Cannot checkout directory outside of VOB") | |
| 1430 (sc-do-command "*CCase*" "co - dir" "cleartool" dpath dpath "co" | |
| 1431 (if comment "-c" "-nc") | |
| 1432 (if comment comment))))) | |
| 1433 | |
| 1434 (defun sc-ccase-checkin-dir () | |
| 1435 "Checkin the directory this file is in" | |
| 1436 (interactive) | |
| 1437 (let ((dpath default-directory) | |
| 1438 (comment (ccase-maybe-comment 'checkin-dir))) | |
| 1439 (if (not (ccase-is-registered dpath)) | |
| 1440 (error "Cannot checkout directory outside of VOB") | |
| 1441 (sc-do-command "*CCase*" "ci - dir" "cleartool" dpath dpath "ci" | |
| 1442 (if comment "-c" "-nc") | |
| 1443 (if comment comment))))) | |
| 1444 | |
| 1445 (defun sc-ccase-editcs () | |
| 1446 "Edit Config Spec for this view" | |
| 1447 (interactive) | |
| 1448 (sc-do-command "*CCase-cs*" "catcs" "cleartool" "" nil "catcs") | |
| 1449 (switch-to-buffer-other-window "*CCase-cs*") | |
| 1450 (local-set-key "\C-c\C-c" 'exit-recursive-edit) | |
| 1451 (recursive-edit) | |
| 1452 (set-buffer "*CCase-cs*") | |
| 1453 (let ((name (make-temp-name "/tmp/configspec"))) | |
| 1454 (write-region (point-min) (point-max) name) | |
| 1455 (kill-buffer "*CCase-cs*") | |
| 1456 (sc-do-command "*CCase*" "setcs" "cleartool" name name "setcs")) | |
| 1457 ) | |
| 1458 | |
| 1459 (defun sc-ccase-new-brtype (brt) | |
| 1460 "Create a new branch type" | |
| 1461 (interactive "sBranch Name: ") | |
| 1462 (let ((comment (ccase-maybe-comment 'new-brtype))) | |
| 1463 (sc-do-command "*CCase*" "mkbrt" "cleartool" brt brt "mkbrtype" | |
| 1464 (if comment "-c" "-nc") | |
| 1465 (if comment comment)))) | |
| 1466 | |
| 1467 (defun sc-ccase-new-branch (brch) | |
| 1468 "Create a new branch for element" | |
| 1469 (interactive "sBranch: ") | |
| 1470 (let ((file (buffer-file-name)) | |
| 1471 (comment (ccase-maybe-comment 'new-branch))) | |
| 1472 (sc-do-command "*CCase*" "mkbrch" "cleartool" file file "mkbranch" | |
| 1473 (if comment "-c" "-nc") | |
| 1474 (if comment comment) | |
| 1475 brch))) | |
| 1476 | |
| 1477 (defun sc-ccase-checkin-merge () | |
| 1478 "Merge in changes to enable checkin" | |
| 1479 (interactive) | |
| 1480 (save-excursion | |
| 1481 (let ((file (buffer-file-name)) | |
| 1482 (buf (current-buffer)) | |
| 1483 (comment (ccase-maybe-comment 'checkin-merge))) | |
| 1484 (sc-do-command "*CCase*" "Describe" "cleartool" file file "des") | |
| 1485 (set-buffer "*CCase*") | |
| 1486 (goto-char (point-min)) | |
| 1487 (if (search-forward-regexp "@@\\([^ \"]*\\)CHECKEDOUT\" from \\([^ ]*\\) (\\([a-z]*\\))" nil t) | |
| 1488 (progn | |
| 1489 (sc-do-command "*CCase*" "Merging" "cleartool" file | |
| 1490 (concat (buffer-substring (match-beginning 1) | |
| 1491 (match-end 1)) "LATEST") | |
| 1492 "merge" | |
| 1493 (if comment "-c" "-nc") | |
| 1494 (if comment comment) | |
| 1495 "-abort" "-to" file "-ver") | |
| 1496 (set-buffer buf) | |
| 1497 (revert-buffer t t) | |
| 1498 (display-buffer "*CCase*")) | |
| 1499 (error "File %s not checked out" file))))) | |
| 1500 | |
| 1501 (defun sc-ccase-version-tree () | |
| 1502 "List version tree for file" | |
| 1503 (interactive) | |
| 1504 (let ((p (buffer-file-name))) | |
| 1505 (sc-do-command "*CCase*" "lsvtree" "cleartool" p p "lsvtree") | |
| 1506 (display-buffer "*CCase*"))) | |
| 1507 | |
| 1508 (defun ccase-protect-expanded-name (revision) | |
| 1509 "Protect ccase extended names from being used as temp names. Munge /s into :s" | |
| 1510 (if (equal sc-generic-name "CCase") | |
| 1511 (progn | |
| 1512 (if (string-match "/" revision) | |
| 1513 (let ((str (substring revision 0)) ;; copy string | |
| 1514 i) | |
| 1515 (while (setq i (string-match "/" str)) | |
| 1516 (aset str i 58)) ; 58 is for : | |
| 1517 str))))) | |
| 1518 | |
| 1519 (defun sc-ccase-list-locked-files () | |
| 1520 (interactive) | |
| 1521 (sc-do-command "*CCase directory*" "listing" "cleartool" (default-directory) nil "lsco" "-cview")) | |
| 1522 | |
| 1523 (defun sc-ccase-list-all-locked-files () | |
| 1524 (interactive) | |
| 1525 (sc-do-command "*CCase directory*" "listing" "cleartool" (default-directory) nil "lsco")) | |
| 1526 | |
| 1527 (defun sc-ccase-list-registered-files () | |
| 1528 "List files registered in clearcase" | |
| 1529 (interactive) | |
| 1530 (sc-do-command "*CCase directory*" "listing" "cleartool" (default-directory) nil "ls" "-r" "-vis" "-nxname")) | |
| 1531 | |
| 1532 ;;; Instantiation and installation of the menus | |
| 1533 | |
| 1534 ;;; Set the menubar for Lucid Emacs | |
| 1535 (defvar sc-default-menu | |
| 1536 '(["NEXT-OPERATION" sc-next-operation t nil] | |
| 1537 ["Update Current Directory" sc-update-directory t] | |
| 1538 "----" | |
| 1539 ["Revert File" sc-revert-file t nil] | |
| 1540 ["Rename File" sc-rename-this-file t nil] | |
| 1541 "----" | |
| 1542 ["Show Changes" sc-show-changes t] | |
| 1543 ["Show Changes Since Revision..." sc-show-revision-changes t] | |
| 1544 ["Visit Previous Revision..." sc-visit-previous-revision t] | |
| 1545 ["Show Edit History" sc-show-history t] | |
| 1546 "----" | |
| 1547 ["List Locked Files" sc-list-locked-files t] | |
| 1548 ["List Locked Files Any User" sc-list-all-locked-files t] | |
| 1549 ["List Registered Files" sc-list-registered-files t]) | |
| 1550 "Menubar entry for using the revision control system.") | |
| 1551 | |
| 1552 (defvar sc-cvs-menu | |
| 1553 '(["Update Current Directory" sc-cvs-update-directory t] | |
| 1554 ["Revert File" sc-revert-file t nil] | |
| 1555 "----" | |
| 1556 ["Show Changes" sc-show-changes t] | |
| 1557 ["Show Changes Since Revision..." sc-show-revision-changes t] | |
| 1558 ["Visit Previous Revision..." sc-visit-previous-revision t] | |
| 1559 ["Show File Status" sc-cvs-file-status t] | |
| 1560 ["Show Edit History" sc-show-history t]) | |
| 1561 "Menubar entry for using the revision control system with CVS.") | |
| 1562 | |
| 1563 (defvar sc-ccase-menu | |
| 1564 '(["NEXT-OPERATION" sc-next-operation t nil] | |
| 1565 ["Revert File" sc-revert-file t nil] | |
| 1566 ["Checkin Merge" sc-ccase-checkin-merge t] | |
| 1567 "----" | |
| 1568 ["Show Changes" sc-show-changes t] | |
| 1569 ["Show Changes Since Revision..." sc-show-revision-changes t] | |
| 1570 ["Visit Previous Revision..." sc-visit-previous-revision t] | |
| 1571 ["Show Edit History" sc-show-history t] | |
| 1572 "----" | |
| 1573 ("Directories" | |
| 1574 ["Checkout Directory" sc-ccase-checkout-dir t] | |
| 1575 ["Checkin Directory" sc-ccase-checkin-dir t] | |
| 1576 ["Rename File..." sc-rename-this-file t nil]) | |
| 1577 ("Configs" | |
| 1578 ["Edit Config Spec..." sc-ccase-editcs t] | |
| 1579 ["Create New Branch..." sc-ccase-new-brtype t] | |
| 1580 ["Make New Branch..." sc-ccase-new-branch t]) | |
| 1581 ("Listings" | |
| 1582 ["List Version Tree" sc-ccase-version-tree t] | |
| 1583 ["List Locked Files" sc-ccase-list-locked-files t] | |
| 1584 ["List Locked Files Any User" sc-ccase-list-all-locked-files t] | |
| 1585 ["List Registered Files" sc-ccase-list-registered-files t] | |
| 1586 )) | |
| 1587 "Menubar entry for using the revision control system.") | |
| 1588 | |
| 1589 (defun sc-sensitize-menu () | |
| 1590 (let* ((rest (cdr (car | |
| 1591 (find-menu-item current-menubar (list sc-generic-name))))) | |
| 1592 (case-fold-search t) | |
| 1593 (file (if buffer-file-name | |
| 1594 (file-name-nondirectory buffer-file-name) | |
| 1595 (buffer-name))) | |
| 1596 (lock-info (sc-lock-info buffer-file-name)) | |
| 1597 command | |
| 1598 nested-rest | |
| 1599 item) | |
| 1600 (while rest | |
| 1601 (setq item (car rest)) | |
| 1602 (if (listp item) | |
| 1603 (progn | |
| 1604 (setq nested-rest (cons (cdr rest) nested-rest)) | |
| 1605 (setq rest (cdr item))) | |
| 1606 (if (vectorp item) | |
| 1607 (progn | |
| 1608 (setq command (aref item 1)) | |
| 1609 (cond ((eq 'sc-next-operation command) | |
| 1610 (aset item 0 | |
| 1611 (cond ((eq lock-info 'na) "Not Available") | |
| 1612 ((not lock-info) "Register File") | |
| 1613 ((not (car lock-info)) "Check out File") | |
| 1614 (t "Check in File"))) | |
| 1615 ;; if locked by somebody else disable the next-operation | |
| 1616 (if (or (not buffer-file-name) | |
| 1617 (eq lock-info 'na) | |
| 1618 (and (car lock-info) | |
| 1619 (not (equal sc-generic-name "CCase")) | |
| 1620 (not (equal (car lock-info) (user-login-name))))) | |
| 1621 (aset item 2 ()) | |
| 1622 (aset item 2 t))) | |
| 1623 ((eq lock-info 'na) (aset item 2 ())) | |
| 1624 ((> (length item) 3) | |
| 1625 (aset item 3 file)) | |
| 1626 (t nil)) | |
| 1627 (if (not (eq lock-info 'na)) | |
| 1628 (let ((enable-file-items | |
| 1629 (if (member sc-generic-name '("CVS" "CCase")) | |
| 1630 buffer-file-name | |
| 1631 (if lock-info t ())))) | |
| 1632 (if (memq command | |
| 1633 '(sc-force-check-in-file | |
| 1634 sc-register-file | |
| 1635 sc-revert-file | |
| 1636 sc-rename-this-file | |
| 1637 sc-show-history | |
| 1638 sc-show-changes | |
| 1639 sc-show-revision-changes | |
| 1640 sc-visit-previous-revision | |
| 1641 sc-cvs-file-status | |
| 1642 sc-ccase-checkout-dir | |
| 1643 sc-ccase-checkin-dir | |
| 1644 sc-ccase-editcs | |
| 1645 sc-ccase-new-brtype | |
| 1646 sc-ccase-new-branch | |
| 1647 sc-ccase-checkin-merge | |
| 1648 sc-ccase-needs-merge | |
| 1649 sc-ccase-merge-changes | |
| 1650 sc-ccase-create-label | |
| 1651 sc-ccase-label-sources | |
| 1652 sc-ccase-version-tree | |
| 1653 sc-list-locked-files | |
| 1654 sc-list-all-locked-files | |
| 1655 sc-ccase-list-registered-files | |
| 1656 )) | |
| 1657 (aset item 2 enable-file-items)))))) | |
| 1658 (if (not (setq rest (cdr rest))) | |
| 1659 (if nested-rest | |
| 1660 (progn | |
| 1661 (setq rest (car nested-rest)) | |
| 1662 (setq nested-rest (cdr nested-rest))))))) | |
| 1663 nil)) | |
| 1664 | |
| 1665 | |
| 1666 ;;; Function to decide which Source control to use | |
| 1667 (defun sc-set-SCCS-mode () | |
| 1668 (setq sc-generic-name "SCCS") | |
| 1669 (setq sc-can-hack-dir t) | |
| 1670 (setq sc-generic-lock-info 'sccs-lock-info) | |
| 1671 (setq sc-generic-register 'sccs-register) | |
| 1672 (setq sc-generic-check-out 'sccs-check-out) | |
| 1673 (setq sc-generic-get-version 'sccs-get-version) | |
| 1674 (setq sc-generic-check-in 'sccs-check-in) | |
| 1675 (setq sc-generic-history 'sccs-history) | |
| 1676 (setq sc-generic-tree-list 'sccs-tree-list) | |
| 1677 (setq sc-generic-new-revision-p 'sccs-new-revision-p) | |
| 1678 (setq sc-generic-revert 'sccs-revert) | |
| 1679 (setq sc-generic-rename 'sccs-rename) | |
| 1680 (setq sc-menu | |
| 1681 (cons (car sc-default-menu) | |
| 1682 (cons ["Insert Headers" sccs-insert-headers t] | |
| 1683 (cdr sc-default-menu)))) | |
| 1684 (define-key sc-prefix-map "h" 'sccs-insert-headers) | |
| 1685 (define-key sc-prefix-map "\C-d" 'sc-update-directory)) | |
| 1686 | |
| 1687 (defun sc-set-RCS-mode () | |
| 1688 (setq sc-generic-name "RCS") | |
| 1689 (setq sc-can-hack-dir t) | |
| 1690 (setq sc-generic-lock-info 'rcs-lock-info) | |
| 1691 (setq sc-generic-register 'rcs-register) | |
| 1692 (setq sc-generic-check-out 'rcs-check-out) | |
| 1693 (setq sc-generic-get-version 'rcs-get-version) | |
| 1694 (setq sc-generic-check-in 'rcs-check-in) | |
| 1695 (setq sc-generic-history 'rcs-history) | |
| 1696 (setq sc-generic-tree-list 'rcs-tree-list) | |
| 1697 (setq sc-generic-new-revision-p 'rcs-new-revision-p) | |
| 1698 (setq sc-generic-revert 'rcs-revert) | |
| 1699 (setq sc-generic-rename 'rcs-rename) | |
| 1700 (setq sc-menu sc-default-menu) | |
| 1701 (define-key sc-prefix-map "\C-d" 'sc-update-directory)) | |
| 1702 | |
| 1703 (defun sc-set-CVS-mode () | |
| 1704 (require 'pcl-cvs) | |
| 1705 (setq sc-generic-name "CVS") | |
| 1706 (setq sc-can-hack-dir t) | |
| 1707 (setq sc-generic-lock-info 'cvs-lock-info) | |
| 1708 (setq sc-generic-register 'cvs-register) | |
| 1709 (setq sc-generic-check-out 'cvs-check-out) | |
| 1710 (setq sc-generic-get-version 'cvs-get-version) | |
| 1711 (setq sc-generic-check-in 'cvs-check-in) | |
| 1712 (setq sc-generic-history 'cvs-history) | |
| 1713 (setq sc-generic-tree-list 'cvs-tree-list) | |
| 1714 (setq sc-generic-new-revision-p 'cvs-new-revision-p) | |
| 1715 (setq sc-generic-revert 'cvs-revert) | |
| 1716 (setq sc-generic-rename 'cvs-rename) | |
| 1717 (setq sc-menu sc-cvs-menu) | |
| 1718 (define-key sc-prefix-map "\C-d" 'sc-cvs-update-directory) | |
| 1719 (define-key sc-prefix-map "s" 'sc-cvs-file-status)) | |
| 1720 | |
| 1721 (defun sc-set-CLEARCASE-mode () | |
| 1722 (setq sc-generic-name "CCase") | |
| 1723 (setq sc-can-hack-dir nil) | |
| 1724 (setq sc-generic-lock-info 'ccase-lock-info) | |
| 1725 (setq sc-generic-register 'ccase-register) | |
| 1726 (setq sc-generic-check-out 'ccase-check-out) | |
| 1727 (setq sc-generic-get-version 'ccase-get-version) | |
| 1728 (setq sc-generic-check-in 'ccase-check-in) | |
| 1729 (setq sc-generic-history 'ccase-history) | |
| 1730 (setq sc-generic-tree-list 'ccase-tree-list) | |
| 1731 (setq sc-generic-new-revision-p 'ccase-new-revision-p) | |
| 1732 (setq sc-generic-revert 'ccase-revert) | |
| 1733 (setq sc-generic-rename 'ccase-rename) | |
| 1734 (setq sc-menu sc-ccase-menu) | |
| 1735 | |
| 1736 ;; caching for file directory types | |
| 1737 (save-excursion | |
| 1738 (set-buffer (get-buffer-create "*CCase*")) | |
| 1739 (shell-command-on-region (point-min) (point-max) "df -t mfs | sed -n 's%.*[ ]\\(/[^ ]*\\)$%\\1%p'" t) | |
| 1740 (goto-char (point-min)) | |
| 1741 (let (x l) | |
| 1742 (while (condition-case nil (setq x (read (current-buffer))) | |
| 1743 (error nil)) | |
| 1744 (setq l (cons (prin1-to-string x) l))) | |
| 1745 (setq sc-ccase-mfs-prefixes (nreverse l)))) | |
| 1746 ) | |
| 1747 | |
| 1748 (defun sc-set-ATRIA-mode () | |
| 1749 (sc-set-CLEARCASE-mode)) | |
| 1750 | |
| 1751 (defun sc-set-CCASE-mode () | |
| 1752 (sc-set-CLEARCASE-mode)) | |
| 1753 | |
| 1754 | |
| 1755 ;; the module is sucessfully loaded! | |
| 1756 (provide 'generic-sc) | |
| 1757 | |
| 1758 ;;; generic-sc.el ends here |