1 ;;; clearcase.el --- ClearCase/Emacs integration.
3 ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004 Kevin Esler
5 ;; Author: Kevin Esler <kaesler@us.ibm.com>
6 ;; Maintainer: Kevin Esler <kaesler@us.ibm.com>
7 ;; Keywords: clearcase tools
8 ;; Web home: http://members.verizon.net/~vze24fr2/EmacsClearCase
10 ;; This file is not part of GNU Emacs.
12 ;; This program is free software; you can redistribute it and/or modify it under
13 ;; the terms of the GNU General Public License as published by the Free Software
14 ;; Foundation; either version 2, or (at your option) any later version.
16 ;; This program is distributed in the hope that it will be useful, but WITHOUT
17 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
18 ;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
21 ;; You should have received a copy of the GNU General Public License along with
22 ;; GNU Emacs; see the file COPYING. If not, write to the Free Software
23 ;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
27 ;; This is a ClearCase/Emacs integration.
33 ;; 0. Make sure you're using Gnu Emacs-20.4 or later or a recent XEmacs.
34 ;; In general it seems to work better in Gnu Emacs than in XEmacs,
35 ;; although many XEmacs users have no problems at all with it.
37 ;; 1. Make sure that you DON'T load old versions of vc-hooks.el which contain
38 ;; incompatible versions of the tq package (functions tq-enqueue and
39 ;; friends). In particular, Bill Sommerfeld's VC/CC integration has this
42 ;; 2. Copy the files (or at least the clearcase.elc file) to a directory
43 ;; on your emacs-load-path.
45 ;; 3. Insert this in your emacs startup file: (load "clearcase")
47 ;; When you begin editing in any view-context, a ClearCase menu will appear
48 ;; and ClearCase Minor Mode will be activated for you.
50 ;; Summary of features
51 ;; ===================
53 ;; Keybindings compatible with Emacs' VC (where it makes sense)
54 ;; Richer interface than VC
55 ;; Works on NT and Unix
56 ;; Context sensitive menu (Emacs knows the ClearCase-status of files)
57 ;; Snapshot view support: update, version comparisons
58 ;; Can use Emacs Ediff for version comparison display
60 ;; - en masse checkin/out etc
62 ;; - browse version tree
63 ;; Completion of viewnames, version strings
64 ;; Auto starting of views referenced as /view/TAG/.. (or \\view\TAG\...)
65 ;; Emacs for editing comments, config specs
66 ;; Standard ClearCase GUI tools launchable from Emacs menu
67 ;; - version tree browser
71 ;; Operations directly available from Emacs menu/keymap:
82 ;; snapshot view update: file, directory, view
83 ;; version comparisons using ediff, diff or GUI
91 ;; The help of the following is gratefully acknowledged:
93 ;; XEmacs support and other bugfixes:
99 ;; This was a result of examining earlier versions of VC and VC/ClearCase
100 ;; integrations and borrowing freely therefrom. Accordingly, the following
101 ;; are ackowledged as contributors:
103 ;; VC/ClearCase integration authors:
122 ;; Jonathan Stigelman
125 ;; Other Contributors:
148 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
154 (defconst clearcase-version-stamp "ClearCase-version: </main/laptop/165>")
155 (defconst clearcase-version (substring clearcase-version-stamp 19))
157 (defun clearcase-maintainer-address ()
160 (concat "kevin.esler.1989"
164 (defconst clearcase-xemacs-package-maintainer-address
165 "Michael Diers <mdiers@xemacs.org>, xemacs-beta@xemacs.org")
167 (defun clearcase-submit-bug-report ()
168 "Submit via mail a bug report on ClearCase Mode"
171 (if (string-match "XEmacs" emacs-version)
172 clearcase-xemacs-package-maintainer-address
173 (clearcase-maintainer-address))))
174 (and (y-or-n-p "Do you really want to submit a report on ClearCase Mode ? ")
175 (reporter-submit-bug-report
177 (concat "clearcase.el " clearcase-version)
182 clearcase-clearcase-version-installed
183 clearcase-cleartool-path
189 clearcase-servers-online
192 clearcase-setview-root
193 clearcase-suppress-vc-within-mvfs
195 w32-quote-process-args
202 (defmacro clearcase-when-debugging (&rest forms)
203 (list 'if 'clearcase-debug (cons 'progn forms)))
205 (defmacro clearcase-with-tempfile (filename-var &rest forms)
206 `(let ((,filename-var (clearcase-utl-tempfile-name)))
212 (if (file-exists-p ,filename-var)
213 (delete-file ,filename-var)))))
219 (defvar clearcase-xemacs-p (string-match "XEmacs" emacs-version))
221 (defvar clearcase-on-mswindows (memq system-type
222 '(windows-nt ms-windows cygwin cygwin32)))
224 (defvar clearcase-on-cygwin (memq system-type '(cygwin cygwin32)))
226 (defvar clearcase-sink-file-name
228 (clearcase-on-cygwin "/dev/null")
229 (clearcase-on-mswindows "NUL")
232 (defun clearcase-view-mode-quit (buf)
233 "Exit from View mode, restoring the previous window configuration."
235 (cond ((frame-property (selected-frame) 'clearcase-view-window-config)
236 (set-window-configuration
237 (frame-property (selected-frame) 'clearcase-view-window-config))
238 (set-frame-property (selected-frame) 'clearcase-view-window-config nil))
239 ((not (one-window-p))
243 (defun clearcase-view-mode (arg &optional camefrom)
244 (if clearcase-xemacs-p
245 (let* ((winconfig (current-window-configuration))
246 (was-one-window (one-window-p))
247 (buffer-name (buffer-name (current-buffer)))
248 (clearcase-view-not-visible
249 (not (and (windows-of-buffer buffer-name) ;shortcut
250 (memq (selected-frame)
251 (mapcar 'window-frame
252 (windows-of-buffer buffer-name)))))))
253 (when clearcase-view-not-visible
254 (set-frame-property (selected-frame)
255 'clearcase-view-window-config winconfig))
256 (view-mode camefrom 'clearcase-view-mode-quit)
257 (setq buffer-read-only nil))
260 (defun clearcase-port-view-buffer-other-window (buffer)
261 (if clearcase-xemacs-p
262 (switch-to-buffer-other-window buffer)
263 (view-buffer-other-window buffer nil 'kill-buffer)))
265 (defun clearcase-dired-sort-by-date ()
266 (if (fboundp 'dired-sort-by-date)
267 (dired-sort-by-date)))
269 ;; Copied from emacs-20
271 (if (not (fboundp 'subst-char-in-string))
272 (defun subst-char-in-string (fromchar tochar string &optional inplace)
273 "Replace FROMCHAR with TOCHAR in STRING each time it occurs.
274 Unless optional argument INPLACE is non-nil, return a new string."
275 (let ((i (length string))
276 (newstr (if inplace string (copy-sequence string))))
279 (if (eq (aref newstr i) fromchar)
280 (aset newstr i tochar)))
287 ;; nyi: we also use these at the moment:
297 (require 'executable)
300 (or clearcase-xemacs-p
303 ;; NT Emacs - doesn't use tq.
305 (if (not clearcase-on-mswindows)
310 ;;{{{ Debugging facilities
312 ;; Setting this to true will enable some debug code.
314 (defvar clearcase-debug nil)
316 (defun clearcase-trace (string)
317 (clearcase-when-debugging
318 (let ((trace-buf (get-buffer "*clearcase-trace*")))
321 (set-buffer trace-buf)
322 (goto-char (point-max))
323 (insert string "\n"))))))
325 (defun clearcase-enable-tracing ()
327 (setq clearcase-debug t)
328 (get-buffer-create "*clearcase-trace*"))
330 (defun clearcase-disable-tracing ()
332 (setq clearcase-debug nil))
334 (defun clearcase-dump ()
336 (clearcase-utl-populate-and-view-buffer
340 (clearcase-fprop-dump-to-current-buffer)
341 (clearcase-vprop-dump-to-current-buffer)))))
343 (defun clearcase-flush-caches ()
345 (clearcase-fprop-clear-all-properties)
346 (clearcase-vprop-clear-all-properties))
350 ;;{{{ Customizable variables
356 (if (and (featurep 'custom)
357 (fboundp 'custom-declare-variable))
358 nil ;; We've got what we needed
359 ;; We have the old custom-library, hack around it!
360 (defmacro defgroup (&rest args)
362 (defmacro defcustom (var value doc &rest args)
363 (` (defvar (, var) (, value) (, doc))))
364 (defmacro defface (face value doc &rest stuff)
366 (defmacro custom-declare-variable (symbol value doc &rest args)
367 (list 'defvar (eval symbol) value doc))))
369 (defgroup clearcase () "ClearCase Options" :group 'tools :prefix "clearcase")
371 (defcustom clearcase-keep-uncheckouts t
372 "When true, the contents of an undone checkout will be kept in a file
373 with a \".keep\" suffix. Otherwise it will be removed."
377 (defcustom clearcase-keep-unhijacks t
378 "When true, the contents of an undone hijack will be kept in a file
379 with a \".keep\" suffix. Otherwise it will be removed."
383 (defcustom clearcase-remove-branch-after-unheckout-when-only-0-version t
384 "When true, after a file has been unchecked out, if the version is .../0, remove the branch."
388 ;; nyi: We could also allow a value of 'prompt here
390 (defcustom clearcase-set-to-new-activity t
391 "*If this variable is non-nil when a new activity is created, that activity
392 will be set as the current activity for the view, otherwise no change is made
393 to the view's current activity setting."
397 (defcustom clearcase-prompt-for-activity-names t
398 "*If this variable is non-nil the user will be prompted for activity names.
399 Otherwise, activity names will be generated automatically and will typically
400 have the form \"activity011112.155233\". If the name entered is empty sucn an
401 internal name will also be generated."
405 (defcustom clearcase-make-backup-files nil
406 "*If non-nil, backups of ClearCase files are made as with other files.
407 If nil (the default), files under ClearCase control don't get backups."
411 (defcustom clearcase-complete-viewtags t
412 "*If non-nil, completion on viewtags is enabled. For sites with thousands of view
413 this should be set to nil."
417 (defcustom clearcase-minimise-menus nil
418 "*If non-nil, menus will hide rather than grey-out inapplicable choices."
422 (defcustom clearcase-auto-dired-mode t
423 "*If non-nil, automatically enter `clearcase-dired-mode' in dired-mode
424 for directories in ClearCase."
428 (defcustom clearcase-dired-highlight t
429 "If non-nil, highlight reserved files in clearcase-dired buffers."
433 (defcustom clearcase-dired-show-view t
434 "If non-nil, show the view tag in dired buffers."
438 (defcustom clearcase-verify-pre-mkelem-dir-checkout nil
439 "*If non-nil, prompt before checking out the containing directory
440 before creating a new ClearCase element."
444 (defcustom clearcase-diff-on-checkin nil
445 "Display diff on checkin to help you compose the checkin comment."
449 ;; General customization
451 (defcustom clearcase-suppress-confirm nil
452 "If non-nil, treat user as expert; suppress yes-no prompts on some things."
456 (defcustom clearcase-initial-mkelem-comment nil
457 "Prompt for initial comment when an element is created."
461 (defcustom clearcase-command-messages nil
462 "Display run messages from back-end commands."
466 (defcustom clearcase-checkin-arguments
467 ;; For backwards compatibility with old name for this variable:
469 (if (and (boundp 'clearcase-checkin-switches)
470 (not (null clearcase-checkin-switches)))
471 (list clearcase-checkin-switches)
473 "A list of extra arguments passed to the checkin command."
475 :type '(repeat (string :tag "Argument")))
477 (defcustom clearcase-checkin-on-mkelem nil
478 "If t, file will be checked-in when first created as an element."
482 (defcustom clearcase-suppress-checkout-comments nil
483 "Suppress prompts for checkout comments for those version control
484 systems which use them."
488 (defcustom clearcase-checkout-arguments
489 ;; For backwards compatibility with old name for this variable:
491 (if (and (boundp 'clearcase-checkout-arguments)
492 (not (null clearcase-checkout-arguments)))
493 (list clearcase-checkout-arguments)
495 "A list of extra arguments passed to the checkout command."
497 :type '(repeat (string :tag "Argument")))
499 (defcustom clearcase-directory-exclusion-list '("lost+found")
500 "Directory names ignored by functions that recursively walk file trees."
502 :type '(repeat (string :tag "Subdirectory")))
504 (defcustom clearcase-use-normal-diff nil
505 "If non-nil, use normal diff instead of cleardiff."
509 (defcustom clearcase-normal-diff-program "diff"
510 "*Program to use for generating the differential of the two files
511 when `clearcase-use-normal-diff' is t."
515 (defcustom clearcase-normal-diff-arguments
516 (if (and (boundp 'clearcase-normal-diff-switches)
517 (not (null clearcase-normal-diff-switches)))
518 (list clearcase-normal-diff-switches)
520 "A list of extra arguments passed to `clearcase-normal-diff-program'
521 when `clearcase-use-normal-diff' is t. Usage of the -u switch is
522 recommended to produce unified diffs, when your
523 `clearcase-normal-diff-program' supports it."
525 :type '(repeat (string :tag "Argument")))
527 (defcustom clearcase-vxpath-glue "@@"
528 "The string used to construct version-extended pathnames."
532 (defcustom clearcase-viewroot (if clearcase-on-mswindows
535 "The ClearCase viewroot directory."
539 (defcustom clearcase-viewroot-drive "m:"
540 "The ClearCase viewroot drive letter for Windows."
544 (defcustom clearcase-suppress-vc-within-mvfs t
545 "Suppresses VC activity within the MVFS."
549 (defcustom clearcase-hide-rebase-activities t
550 "Hide rebase activities from activity selection list."
554 (defcustom clearcase-rebase-id-regexp "^rebase\\."
555 "The regexp used to detect rebase actvities."
559 (defcustom clearcase-annotate-fmt-string "/** %Sd %-8.8u **/"
560 "The -fmt argument passed top cleartool+annotate when it is called."
566 ;;{{{ Global variables
568 ;; Initialize clearcase-pname-sep-regexp according to
569 ;; directory-sep-char.
570 (defvar clearcase-pname-sep-regexp
572 (char-to-string directory-sep-char)))
574 (defvar clearcase-non-pname-sep-regexp
576 (char-to-string directory-sep-char)))
578 ;; Matches any viewtag (without the trailing "/").
580 (defvar clearcase-viewtag-regexp
583 clearcase-pname-sep-regexp
585 clearcase-non-pname-sep-regexp "*"
590 ;; Matches ANY viewroot-relative path
592 (defvar clearcase-vrpath-regexp
595 clearcase-pname-sep-regexp
597 clearcase-non-pname-sep-regexp "*"
603 ;;{{{ Minor Mode: ClearCase
605 ;; For ClearCase Minor Mode
607 (defvar clearcase-mode nil)
608 (set-default 'clearcase-mode nil)
609 (make-variable-buffer-local 'clearcase-mode)
610 (put 'clearcase-mode 'permanent-local t)
612 ;; Tell Emacs about this new kind of minor mode
614 (if (not (assoc 'clearcase-mode minor-mode-alist))
615 (setq minor-mode-alist (cons '(clearcase-mode clearcase-mode)
618 ;; For now we override the bindings for VC Minor Mode with ClearCase Minor Mode
621 (defvar clearcase-mode-map (make-sparse-keymap))
622 (defvar clearcase-prefix-map (make-sparse-keymap))
623 (define-key clearcase-mode-map "\C-xv" clearcase-prefix-map)
624 (define-key clearcase-mode-map "\C-x\C-q" 'clearcase-toggle-read-only)
626 (define-key clearcase-prefix-map "b" 'clearcase-browse-vtree-current-buffer)
627 (define-key clearcase-prefix-map "c" 'clearcase-uncheckout-current-buffer)
628 (define-key clearcase-prefix-map "e" 'clearcase-edcs-edit)
629 (define-key clearcase-prefix-map "g" 'clearcase-annotate-current-buffer)
630 (define-key clearcase-prefix-map "i" 'clearcase-mkelem-current-buffer)
631 (define-key clearcase-prefix-map "l" 'clearcase-list-history-current-buffer)
632 (define-key clearcase-prefix-map "m" 'clearcase-mkbrtype)
633 (define-key clearcase-prefix-map "u" 'clearcase-uncheckout-current-buffer)
634 (define-key clearcase-prefix-map "v" 'clearcase-next-action-current-buffer)
635 (define-key clearcase-prefix-map "w" 'clearcase-what-rule-current-buffer)
636 (define-key clearcase-prefix-map "=" 'clearcase-diff-pred-current-buffer)
637 (define-key clearcase-prefix-map "?" 'clearcase-describe-current-buffer)
638 (define-key clearcase-prefix-map "~" 'clearcase-version-other-window)
640 ;; To avoid confusion, we prevent VC Mode from being active at all by
641 ;; undefining its keybindings for which ClearCase Mode doesn't yet have an
644 (define-key clearcase-prefix-map "a" 'undefined) ;; vc-update-change-log
645 (define-key clearcase-prefix-map "d" 'undefined) ;; vc-directory
646 (define-key clearcase-prefix-map "h" 'undefined) ;; vc-insert-headers
647 (define-key clearcase-prefix-map "m" 'undefined) ;; vc-merge
648 (define-key clearcase-prefix-map "r" 'undefined) ;; vc-retrieve-snapshot
649 (define-key clearcase-prefix-map "s" 'undefined) ;; vc-create-snapshot
650 (define-key clearcase-prefix-map "t" 'undefined) ;; vc-dired-toggle-terse-mode
652 ;; Associate the map and the minor mode
654 (or (not (boundp 'minor-mode-map-alist))
655 (assq 'clearcase-mode (symbol-value 'minor-mode-map-alist))
656 (setq minor-mode-map-alist
657 (cons (cons 'clearcase-mode clearcase-mode-map)
658 minor-mode-map-alist)))
660 (defun clearcase-mode (&optional arg)
661 "ClearCase Minor Mode"
665 ;; Behave like a proper minor-mode.
672 ;; Check if the numeric arg is positive.
674 (> (prefix-numeric-value arg) 0))
677 ;; Use the car if it's a list.
680 (setq arg (car arg)))
683 (not clearcase-mode) ;; toggle mode switch
684 (not (eq '- arg))) ;; True if symbol is not '-
687 ;; assume it's a number and check that.
692 (easy-menu-add clearcase-menu 'clearcase-mode-map))
697 ;;{{{ Minor Mode: ClearCase Dired
699 ;;{{{ Reformatting the Dired buffer
701 ;; Create a face for highlighting checked out files in clearcase-dired.
703 (if (not (memq 'clearcase-dired-checkedout-face (face-list)))
705 (make-face 'clearcase-dired-checkedout-face)
706 (set-face-foreground 'clearcase-dired-checkedout-face "red")))
708 (defun clearcase-dired-insert-viewtag ()
711 (goto-char (point-min))
713 ;; Only do this if the buffer is not currently narrowed
716 (let ((viewtag (clearcase-fprop-viewtag (file-truename default-directory))))
720 (let ((buffer-read-only nil))
721 (insert (format " [ClearCase View: %s]\n" viewtag))))))))))
723 (defun clearcase-dired-reformat-buffer ()
724 "Reformats the current dired buffer."
725 (let* ((checkout-list nil)
726 (modified-file-info nil)
728 (directory default-directory)
732 ;; Iterate over each line in the buffer.
735 ;; 1. In general, a Dired buffer can contain listings for several
736 ;; directories. We pass though from top to bottom and adjust
738 ;; 2. Since this is called from dired-after-reading-hook, it can get
739 ;; called on a single-line buffer. In this case there is no subdir,
740 ;; and no checkout-list. We need to call clearcase-fprop-checked-out
741 ;; to test for a checkout.
744 (goto-char (point-min))
748 ;; Case 1: Look for directory markers
750 ((setq subdir (dired-get-subdir))
752 ;; We're at a subdirectory line in the dired buffer.
753 ;; Go and list all checkouts and hijacks in this subdirectory.
755 (setq modified-file-info (clearcase-dired-list-modified-files subdir))
756 (setq checkout-list (nth 0 modified-file-info))
757 (setq hijack-list (nth 1 modified-file-info))
759 ;; If no checkouts are found, we don't need to check each file, and
760 ;; it's very slow. The checkout-list should contain something so it
761 ;; doesn't attempt to do this.
763 (if (null checkout-list)
764 (setq checkout-list '(nil)))
765 (if (null hijack-list)
766 (setq hijack-list '(nil)))
767 (message "Reformatting %s..." subdir))
769 ;; Case 2: Look for files (the safest way to get the filename).
771 ((setq fullpath (dired-get-filename nil t))
773 ;; Expand it to get rid of . and .. entries.
775 (setq fullpath (expand-file-name fullpath))
777 (setq fullpath (clearcase-path-canonicalise-slashes fullpath))
779 ;; Only modify directory listings of the correct format.
780 ;; We replace the GID field with a checkout indicator.
784 ;; -rw-rw-rw- 1 esler 5 28 Feb 2 16:02 foo.el
785 "..\\([drwxlts-]+ \\) *\\([0-9]+\\) \\([^ ]+\\) *\\([^ ]+ *\\) +[0-9]+\\( [^ 0-9]+ [0-9 ][0-9] .*\\)")
787 (let* ((replacement-begin (match-beginning 4))
788 (replacement-end (match-end 4))
790 (replacement-length (- replacement-end replacement-begin))
791 (checkout-replacement-text (format "CHECKOUT"))
792 (hijack-replacement-text (format "HIJACK"))
793 (is-checkout (if checkout-list
794 (member fullpath checkout-list)
795 (clearcase-fprop-checked-out fullpath)))
796 (is-hijack (if hijack-list
797 (member fullpath hijack-list)
798 (clearcase-fprop-hijacked fullpath))))
800 ;; Highlight the line if the file is checked-out.
804 ;; Replace the GID field with CHECKOUT.
806 (let ((buffer-read-only nil))
808 ;; Pad with replacement text with trailing spaces if necessary.
810 (if (>= replacement-length (length checkout-replacement-text))
811 (setq checkout-replacement-text
812 (concat checkout-replacement-text
813 (make-string (- replacement-length (length checkout-replacement-text))
815 (goto-char replacement-begin)
816 (delete-char replacement-length)
817 (insert (substring checkout-replacement-text 0 replacement-length)))
819 ;; Highlight the checked out files.
821 (if (fboundp 'put-text-property)
822 (let ((buffer-read-only nil))
823 (put-text-property replacement-begin replacement-end
824 'face 'clearcase-dired-checkedout-face)))
830 ;; Replace the GID field with CHECKOUT.
832 (let ((buffer-read-only nil))
834 ;; Pad with replacement text with trailing spaces if necessary.
836 (if (>= replacement-length (length hijack-replacement-text))
837 (setq hijack-replacement-text
838 (concat hijack-replacement-text
839 (make-string (- replacement-length (length hijack-replacement-text))
841 (goto-char replacement-begin)
842 (delete-char replacement-length)
843 (insert (substring hijack-replacement-text 0 replacement-length)))
845 ;; Highlight the checked out files.
847 (if (fboundp 'put-text-property)
848 (let ((buffer-read-only nil))
849 (put-text-property replacement-begin replacement-end
850 'face 'clearcase-dired-checkedout-face)))
856 (message "Reformatting...Done"))
859 (defun clearcase-path-follow-if-vob-slink (path)
860 (if (clearcase-fprop-file-is-vob-slink-p path)
862 ;; It's a slink so follow it.
864 (let ((slink-text (clearcase-fprop-vob-slink-text path)))
865 (if (file-name-absolute-p slink-text)
867 (concat (file-name-directory path) slink-text)))
873 ;;{{{ Searching for modified files
877 ;; (defun clearcase-dired-list-checkouts (directory)
878 ;; "Returns a list of files checked-out to the current view in DIRECTORY."
880 ;; ;; Don't bother looking for checkouts in
881 ;; ;; - a history-mode branch-qua-directory
882 ;; ;; - a view-private directory
884 ;; ;; NYI: For now don't run lsco in root of a snapshot because it gives errors.
885 ;; ;; We need to make this smarter.
887 ;; ;; NYI: For a pathname which is a slink to a dir, despite the fact that
888 ;; ;; clearcase-fprop-file-is-version-p returns true, lsco fails on it,
889 ;; ;; with "not an element". Sheesh, surely lsco ought to follow links ?
890 ;; ;; Solution: catch the error and check if the dir is a slink then follow
891 ;; ;; the link and retry the lsco on the target.
893 ;; ;; For now just ignore the error.
895 ;; (if (and (not (clearcase-vxpath-p directory))
896 ;; (not (eq 'view-private-object (clearcase-fprop-mtype directory)))
897 ;; (clearcase-fprop-file-is-version-p directory))
900 ;; (let* ((ignore (message "Listing ClearCase checkouts..."))
902 ;; (true-dir-path (file-truename directory))
904 ;; ;; Give the directory as an argument so all names will be
905 ;; ;; fullpaths. For some reason ClearCase adds an extra slash if you
906 ;; ;; leave the trailing slash on the directory, so we need to remove
909 ;; (native-dir-path (clearcase-path-native (directory-file-name true-dir-path)))
911 ;; (followed-dir-path (clearcase-path-follow-if-vob-slink native-dir-path))
913 ;; ;; Form the command:
916 ;; "lsco" "-cview" "-fmt"
917 ;; (if clearcase-on-mswindows
921 ;; followed-dir-path))
923 ;; ;; Capture the output:
925 ;; (string (clearcase-path-canonicalise-slashes
926 ;; (apply 'clearcase-ct-cleartool-cmd cmd)))
928 ;; ;; Split the output at the newlines:
930 ;; (checkout-list (clearcase-utl-split-string-at-char string ?\n)))
932 ;; ;; Add entries for "." and ".." if they're checked-out.
934 ;; (let* ((entry ".")
935 ;; (path (expand-file-name (concat (file-name-as-directory true-dir-path)
937 ;; (if (clearcase-fprop-checked-out path)
938 ;; (setq checkout-list (cons path checkout-list))))
939 ;; (let* ((entry "..")
940 ;; (path (expand-file-name (concat (file-name-as-directory true-dir-path)
942 ;; (if (clearcase-fprop-checked-out path)
943 ;; (setq checkout-list (cons path checkout-list))))
945 ;; ;; If DIRECTORY is a vob-slink, checkout list will contain pathnames
946 ;; ;; relative to the vob-slink target rather than to DIRECTORY. Convert
947 ;; ;; them back here. We're making it appear that lsco works on
948 ;; ;; slinks-to-dirs.
950 ;; (if (clearcase-fprop-file-is-vob-slink-p true-dir-path)
951 ;; (let ((re (regexp-quote (file-name-as-directory followed-dir-path))))
952 ;; (setq checkout-list
956 ;; (replace-regexp-in-string re true-dir-path path)))
959 ;; (message "Listing ClearCase checkouts...done")
961 ;; ;; Return the result.
966 ;; ;; I had believed that this implementation below OUGHT to be faster, having
967 ;; ;; read the code in "ct+lsco". It seemed that "lsco -cview" hit the VOB and
968 ;; ;; listed all checkouts on all elements in the directory, and then filtered by
969 ;; ;; view. I thought it would probably be quicker to run "ct ls -vob_only" and
970 ;; ;; keep the lines that have "[eclipsed by checkout]". However this code
971 ;; ;; actually seemed to run slower. Leave the code here for now so I can test
974 ;; (defun clearcase-dired-list-checkouts-experimental (directory)
975 ;; "Returns a list of files checked-out to the current view in DIRECTORY."
977 ;; ;; Don't bother looking for checkouts in a history-mode listing
978 ;; ;; nor in view-private directories.
980 ;; (if (and (not (clearcase-vxpath-p directory))
981 ;; (not (eq 'view-private-object (clearcase-fprop-mtype directory))))
983 ;; (let* ((ignore (message "Listing ClearCase checkouts..."))
985 ;; (true-directory (file-truename directory))
987 ;; ;; Move temporarily to the directory:
989 ;; (default-directory true-directory)
991 ;; ;; Form the command:
993 ;; (cmd (list "ls" "-vob_only"))
995 ;; ;; Capture the output:
997 ;; (string (clearcase-path-canonicalise-slashes
998 ;; (apply 'clearcase-ct-cleartool-cmd cmd)))
1000 ;; ;; Split the output at the newlines:
1002 ;; (line-list (clearcase-utl-split-string-at-char string ?\n))
1004 ;; (checkout-list nil))
1006 ;; ;; Look for lines of the form:
1007 ;; ;; FILENAME@@ [eclipsed by checkout]
1009 ;; (mapcar (function
1011 ;; (if (string-match "^\\([^ @]+\\)@@ +\\[eclipsed by checkout\\].*" line)
1012 ;; (setq checkout-list (cons (concat
1013 ;; ;; Add back directory name to get
1014 ;; ;; full pathname.
1016 ;; default-directory
1018 ;; (match-beginning 1)
1020 ;; checkout-list)))))
1023 ;; ;; Add entries for "." and ".." if they're checked-out.
1025 ;; (let* ((entry ".")
1026 ;; (path (expand-file-name (concat true-directory entry))))
1027 ;; (if (clearcase-fprop-checked-out path)
1028 ;; (setq checkout-list (cons path checkout-list))))
1029 ;; (let* ((entry "..")
1030 ;; (path (expand-file-name (concat true-directory entry))))
1031 ;; (if (clearcase-fprop-checked-out path)
1032 ;; (setq checkout-list (cons path checkout-list))))
1034 ;; (message "Listing ClearCase checkouts...done")
1036 ;; ;; Return the result.
1040 ;; (defun clearcase-dired-list-hijacks (directory)
1041 ;; "Returns a list of files hijacked to the current view in DIRECTORY."
1043 ;; ;; Don't bother looking for hijacks in;
1044 ;; ;; - a history-mode listing
1045 ;; ;; - a in view-private directory
1046 ;; ;; - a dynamic view
1048 ;; (let* ((true-directory (file-truename directory))
1049 ;; (viewtag (clearcase-fprop-viewtag true-directory)))
1052 ;; (not (clearcase-vxpath-p directory))
1053 ;; (not (eq 'view-private-object (clearcase-fprop-mtype directory)))
1054 ;; (clearcase-file-would-be-in-snapshot-p true-directory))
1056 ;; (let* ((ignore (message "Listing ClearCase hijacks..."))
1058 ;; (true-directory (file-truename directory))
1060 ;; ;; Form the command:
1065 ;; ;; Give the directory as an argument so all names will be
1066 ;; ;; fullpaths. For some reason ClearCase adds an extra slash
1067 ;; ;; if you leave the trailing slash on the directory, so we
1068 ;; ;; need to remove it.
1070 ;; (clearcase-path-native (directory-file-name true-directory))))
1072 ;; ;; Capture the output:
1074 ;; (string (clearcase-path-canonicalise-slashes
1075 ;; (apply 'clearcase-ct-cleartool-cmd cmd)))
1077 ;; ;; Split the output at the newlines:
1079 ;; (line-list (clearcase-utl-split-string-at-char string ?\n))
1081 ;; (hijack-list nil))
1083 ;; (mapcar (function
1085 ;; (if (string-match "^\\([^ @]+\\)@@[^ ]+ \\[hijacked\\].*" line)
1086 ;; (setq hijack-list (cons (substring line
1087 ;; (match-beginning 1)
1092 ;; (message "Listing ClearCase hijacks...done")
1094 ;; ;; Return the result.
1100 (defun clearcase-dired-list-modified-files (directory)
1101 "Returns a pair of lists of files (checkouts . hijacks) to the current view in DIRECTORY."
1103 ;; Don't bother looking for hijacks in;
1104 ;; - a history-mode listing
1105 ;; - a in view-private directory
1108 (let* ((true-directory (file-truename directory))
1109 (viewtag (clearcase-fprop-viewtag true-directory))
1110 (snapshot (clearcase-file-would-be-in-snapshot-p true-directory))
1114 (not (clearcase-vxpath-p directory))
1115 (not (eq 'view-private-object (clearcase-fprop-mtype directory))))
1117 (let* ((ignore (message "Listing ClearCase modified files..."))
1119 (true-directory (file-truename directory))
1121 ;; Form the command:
1126 ;; Give the directory as an argument so all names will be
1127 ;; fullpaths. For some reason ClearCase adds an extra slash
1128 ;; if you leave the trailing slash on the directory, so we
1129 ;; need to remove it.
1131 (clearcase-path-native (directory-file-name true-directory))))
1133 ;; Capture the output:
1135 (string (clearcase-path-canonicalise-slashes
1136 (apply 'clearcase-ct-cleartool-cmd cmd)))
1138 ;; Split the output at the newlines:
1140 (line-list (clearcase-utl-split-string-at-char string ?\n))
1143 (checkout-list nil))
1147 (if (string-match "^\\([^ @]+\\)@@[^ ]+ \\[hijacked\\].*" line)
1148 (setq hijack-list (cons (substring line
1152 (if (string-match "^\\([^ @]+\\)@@.+CHECKEDOUT from .*" line)
1153 (setq checkout-list (cons (substring line
1159 (message "Listing ClearCase modified files...done")
1161 ;; Return the result.
1163 (setq result (list checkout-list hijack-list))))
1170 ;; For ClearCase Dired Minor Mode
1172 (defvar clearcase-dired-mode nil)
1173 (set-default 'clearcase-dired-mode nil)
1174 (make-variable-buffer-local 'clearcase-dired-mode)
1176 ;; Tell Emacs about this new kind of minor mode
1178 (if (not (assoc 'clearcase-dired-mode minor-mode-alist))
1179 (setq minor-mode-alist (cons '(clearcase-dired-mode clearcase-dired-mode)
1182 ;; For now we override the bindings for VC Minor Mode with ClearCase Dired
1183 ;; Minor Mode bindings.
1185 (defvar clearcase-dired-mode-map (make-sparse-keymap))
1186 (defvar clearcase-dired-prefix-map (make-sparse-keymap))
1187 (define-key clearcase-dired-mode-map "\C-xv" clearcase-dired-prefix-map)
1189 (define-key clearcase-dired-prefix-map "b" 'clearcase-browse-vtree-dired-file)
1190 (define-key clearcase-dired-prefix-map "c" 'clearcase-uncheckout-dired-files)
1191 (define-key clearcase-dired-prefix-map "e" 'clearcase-edcs-edit)
1192 (define-key clearcase-dired-prefix-map "i" 'clearcase-mkelem-dired-files)
1193 (define-key clearcase-dired-prefix-map "g" 'clearcase-annotate-dired-file)
1194 (define-key clearcase-dired-prefix-map "l" 'clearcase-list-history-dired-file)
1195 (define-key clearcase-dired-prefix-map "m" 'clearcase-mkbrtype)
1196 (define-key clearcase-dired-prefix-map "u" 'clearcase-uncheckout-dired-files)
1197 (define-key clearcase-dired-prefix-map "v" 'clearcase-next-action-dired-files)
1198 (define-key clearcase-dired-prefix-map "w" 'clearcase-what-rule-dired-file)
1199 (define-key clearcase-dired-prefix-map "=" 'clearcase-diff-pred-dired-file)
1200 (define-key clearcase-dired-prefix-map "~" 'clearcase-version-other-window)
1201 (define-key clearcase-dired-prefix-map "?" 'clearcase-describe-dired-file)
1203 ;; To avoid confusion, we prevent VC Mode from being active at all by
1204 ;; undefining its keybindings for which ClearCase Mode doesn't yet have an
1207 (define-key clearcase-dired-prefix-map "a" 'undefined) ;; vc-update-change-log
1208 (define-key clearcase-dired-prefix-map "d" 'undefined) ;; vc-directory
1209 (define-key clearcase-dired-prefix-map "h" 'undefined) ;; vc-insert-headers
1210 (define-key clearcase-dired-prefix-map "m" 'undefined) ;; vc-merge
1211 (define-key clearcase-dired-prefix-map "r" 'undefined) ;; vc-retrieve-snapshot
1212 (define-key clearcase-dired-prefix-map "s" 'undefined) ;; vc-create-snapshot
1213 (define-key clearcase-dired-prefix-map "t" 'undefined) ;; vc-dired-toggle-terse-mode
1215 ;; Associate the map and the minor mode
1217 (or (not (boundp 'minor-mode-map-alist))
1218 (assq 'clearcase-dired-mode (symbol-value 'minor-mode-map-alist))
1219 (setq minor-mode-map-alist
1220 (cons (cons 'clearcase-dired-mode clearcase-dired-mode-map)
1221 minor-mode-map-alist)))
1223 (defun clearcase-dired-mode (&optional arg)
1224 "The augmented Dired minor mode used in ClearCase directory buffers.
1225 All Dired commands operate normally. Users with checked-out files
1226 are listed in place of the file's owner and group. Keystrokes bound to
1227 ClearCase Mode commands will execute as though they had been called
1228 on a buffer attached to the file named in the current Dired buffer line."
1232 ;; Behave like a proper minor-mode.
1234 (setq clearcase-dired-mode
1237 (not clearcase-dired-mode)
1239 ;; Check if the numeric arg is positive.
1241 (> (prefix-numeric-value arg) 0))
1244 ;; Use the car if it's a list.
1247 (setq arg (car arg)))
1251 (not clearcase-dired-mode) ;; toggle mode switch
1252 (not (eq '- arg))) ;; True if symbol is not '-
1255 ;; assume it's a number and check that.
1259 (if (not (eq major-mode 'dired-mode))
1260 (setq clearcase-dired-mode nil))
1262 (if (and clearcase-dired-mode clearcase-dired-highlight)
1263 (clearcase-dired-reformat-buffer))
1265 (if clearcase-dired-mode
1266 (easy-menu-add clearcase-dired-menu 'clearcase-dired-mode-map))
1271 ;;{{{ Major Mode: for editing comments.
1273 ;; The major mode function.
1275 (defun clearcase-comment-mode ()
1276 "Major mode for editing comments for ClearCase.
1278 These bindings are added to the global keymap when you enter this mode:
1280 \\[clearcase-next-action-current-buffer] perform next logical version-control operation on current file
1281 \\[clearcase-mkelem-current-buffer] mkelem the current file
1282 \\[clearcase-toggle-read-only] like next-action, but won't create elements
1283 \\[clearcase-list-history-current-buffer] display change history of current file
1284 \\[clearcase-uncheckout-current-buffer] cancel checkout in buffer
1285 \\[clearcase-diff-pred-current-buffer] show diffs between file versions
1286 \\[clearcase-version-other-window] visit old version in another window
1288 While you are entering a comment for a version, the following
1289 additional bindings will be in effect.
1291 \\[clearcase-comment-finish] proceed with check in, ending comment
1293 Whenever you do a checkin, your comment is added to a ring of
1294 saved comments. These can be recalled as follows:
1296 \\[clearcase-comment-next] replace region with next message in comment ring
1297 \\[clearcase-comment-previous] replace region with previous message in comment ring
1298 \\[clearcase-comment-search-reverse] search backward for regexp in the comment ring
1299 \\[clearcase-comment-search-forward] search backward for regexp in the comment ring
1301 Entry to the clearcase-comment-mode calls the value of text-mode-hook, then
1302 the value of clearcase-comment-mode-hook.
1304 Global user options:
1305 clearcase-initial-mkelem-comment If non-nil, require user to enter a change
1306 comment upon first checkin of the file.
1308 clearcase-suppress-confirm Suppresses some confirmation prompts,
1309 notably for reversions.
1311 clearcase-command-messages If non-nil, display run messages from the
1312 actual version-control utilities (this is
1313 intended primarily for people hacking clearcase.el
1318 ;; Major modes are supposed to just (kill-all-local-variables)
1319 ;; but we rely on clearcase-parent-buffer already having been set
1321 ;;(let ((parent clearcase-parent-buffer))
1322 ;; (kill-all-local-variables)
1323 ;; (set (make-local-variable 'clearcase-parent-buffer) parent))
1325 (setq major-mode 'clearcase-comment-mode)
1326 (setq mode-name "ClearCase/Comment")
1328 (set-syntax-table text-mode-syntax-table)
1329 (use-local-map clearcase-comment-mode-map)
1330 (setq local-abbrev-table text-mode-abbrev-table)
1332 (make-local-variable 'clearcase-comment-operands)
1333 (make-local-variable 'clearcase-comment-ring-index)
1335 (set-buffer-modified-p nil)
1336 (setq buffer-file-name nil)
1337 (run-hooks 'text-mode-hook 'clearcase-comment-mode-hook))
1341 (defvar clearcase-comment-mode-map nil)
1342 (if clearcase-comment-mode-map
1344 (setq clearcase-comment-mode-map (make-sparse-keymap))
1345 (define-key clearcase-comment-mode-map "\M-n" 'clearcase-comment-next)
1346 (define-key clearcase-comment-mode-map "\M-p" 'clearcase-comment-previous)
1347 (define-key clearcase-comment-mode-map "\M-r" 'clearcase-comment-search-reverse)
1348 (define-key clearcase-comment-mode-map "\M-s" 'clearcase-comment-search-forward)
1349 (define-key clearcase-comment-mode-map "\C-c\C-c" 'clearcase-comment-finish)
1350 (define-key clearcase-comment-mode-map "\C-x\C-s" 'clearcase-comment-save)
1351 (define-key clearcase-comment-mode-map "\C-x\C-q" 'clearcase-comment-num-num-error))
1355 (defconst clearcase-comment-maximum-ring-size 32
1356 "Maximum number of saved comments in the comment ring.")
1360 (defvar clearcase-comment-entry-mode nil)
1361 (defvar clearcase-comment-operation nil)
1362 (defvar clearcase-comment-operands)
1363 (defvar clearcase-comment-ring nil)
1364 (defvar clearcase-comment-ring-index nil)
1365 (defvar clearcase-comment-last-match nil)
1366 (defvar clearcase-comment-window-config nil)
1368 ;; In several contexts, this is a local variable that points to the buffer for
1369 ;; which it was made (either a file, or a ClearCase dired buffer).
1371 (defvar clearcase-parent-buffer nil)
1372 (defvar clearcase-parent-buffer-name nil)
1374 ;;{{{ Commands and functions
1376 (defun clearcase-comment-start-entry (uniquifier
1380 &optional parent-buffer comment-seed)
1382 "Accept a comment by popping up a clearcase-comment-mode buffer
1383 with a name derived from UNIQUIFIER, and emitting PROMPT in the minibuffer.
1384 Set the continuation on close to CONTINUATION, which should be apply-ed to a list
1385 formed by appending OPERANDS and the comment-string.
1387 Optional 5th argument specifies a PARENT-BUFFER to return to when the operation
1390 Optional 6th argument specifies a COMMENT-SEED to insert in the comment buffer for
1393 (let ((comment-buffer (get-buffer-create (format "*clearcase-comment-%s*" uniquifier)))
1394 (old-window-config (current-window-configuration))
1395 (parent (or parent-buffer
1397 (pop-to-buffer comment-buffer)
1399 ;; Record in buffer-local variables information sufficient to restore
1402 (set (make-local-variable 'clearcase-comment-window-config) old-window-config)
1403 (set (make-local-variable 'clearcase-parent-buffer) parent)
1405 (clearcase-comment-mode)
1406 (setq clearcase-comment-operation continuation)
1407 (setq clearcase-comment-operands operands)
1409 (insert comment-seed))
1410 (message "%s Type C-c C-c when done." prompt)))
1413 (defun clearcase-comment-cleanup ()
1414 ;; Make sure it ends with newline
1416 (goto-char (point-max))
1420 ;; Remove useless whitespace.
1422 (goto-char (point-min))
1423 (while (re-search-forward "[ \t]+$" nil t)
1426 ;; Remove trailing newlines, whitespace.
1428 (goto-char (point-max))
1429 (skip-chars-backward " \n\t")
1430 (delete-region (point) (point-max)))
1432 (defun clearcase-comment-finish ()
1433 "Complete the operation implied by the current comment."
1436 ;;Clean and record the comment in the ring.
1438 (let ((comment-buffer (current-buffer)))
1439 (clearcase-comment-cleanup)
1441 (if (null clearcase-comment-ring)
1442 (setq clearcase-comment-ring (make-ring clearcase-comment-maximum-ring-size)))
1443 (ring-insert clearcase-comment-ring (buffer-string))
1445 ;; Perform the operation on the operands.
1447 (if clearcase-comment-operation
1449 (apply clearcase-comment-operation
1450 (append clearcase-comment-operands (list (buffer-string)))))
1451 (error "No comment operation is pending"))
1453 ;; Return to "parent" buffer of this operation.
1454 ;; Remove comment window.
1456 (let ((old-window-config clearcase-comment-window-config))
1457 (pop-to-buffer clearcase-parent-buffer)
1458 (delete-windows-on comment-buffer)
1459 (kill-buffer comment-buffer)
1460 (if old-window-config (set-window-configuration old-window-config)))))
1462 (defun clearcase-comment-save-comment-for-buffer (comment buffer)
1465 (let ((file (buffer-file-name)))
1466 (if (clearcase-fprop-checked-out file)
1468 (clearcase-ct-do-cleartool-command "chevent"
1472 (clearcase-fprop-set-comment file comment))
1473 (error "Can't change comment of checked-in version with this interface")))))
1475 (defun clearcase-comment-save ()
1476 "Save the currently entered comment"
1478 (let ((comment-string (buffer-string))
1479 (parent-buffer clearcase-parent-buffer))
1480 (if (not (buffer-modified-p))
1481 (message "(No changes need to be saved)")
1484 (set-buffer parent-buffer)
1485 (clearcase-comment-save-comment-for-buffer comment-string parent-buffer))
1487 (set-buffer-modified-p nil)))))
1489 (defun clearcase-comment-num-num-error ()
1491 (message "Perhaps you wanted to type C-c C-c instead?"))
1493 ;; Code for the comment ring.
1495 (defun clearcase-comment-next (arg)
1496 "Cycle forwards through comment history."
1498 (clearcase-comment-previous (- arg)))
1500 (defun clearcase-comment-previous (arg)
1501 "Cycle backwards through comment history."
1503 (let ((len (ring-length clearcase-comment-ring)))
1504 (cond ((or (not len) (<= len 0))
1505 (message "Empty comment ring")
1510 ;; Initialize the index on the first use of this command so that the
1511 ;; first M-p gets index 0, and the first M-n gets index -1.
1513 (if (null clearcase-comment-ring-index)
1514 (setq clearcase-comment-ring-index
1516 (if (< arg 0) 1 0))))
1517 (setq clearcase-comment-ring-index
1518 (mod (+ clearcase-comment-ring-index arg) len))
1519 (message "%d" (1+ clearcase-comment-ring-index))
1520 (insert (ring-ref clearcase-comment-ring clearcase-comment-ring-index))))))
1522 (defun clearcase-comment-search-forward (str)
1523 "Searches forwards through comment history for substring match."
1524 (interactive "sComment substring: ")
1525 (if (string= str "")
1526 (setq str clearcase-comment-last-match)
1527 (setq clearcase-comment-last-match str))
1528 (if (null clearcase-comment-ring-index)
1529 (setq clearcase-comment-ring-index 0))
1530 (let ((str (regexp-quote str))
1531 (n clearcase-comment-ring-index))
1532 (while (and (>= n 0) (not (string-match str (ring-ref clearcase-comment-ring n))))
1535 (clearcase-comment-next (- n clearcase-comment-ring-index)))
1536 (t (error "Not found")))))
1538 (defun clearcase-comment-search-reverse (str)
1539 "Searches backwards through comment history for substring match."
1540 (interactive "sComment substring: ")
1541 (if (string= str "")
1542 (setq str clearcase-comment-last-match)
1543 (setq clearcase-comment-last-match str))
1544 (if (null clearcase-comment-ring-index)
1545 (setq clearcase-comment-ring-index -1))
1546 (let ((str (regexp-quote str))
1547 (len (ring-length clearcase-comment-ring))
1548 (n (1+ clearcase-comment-ring-index)))
1549 (while (and (< n len)
1550 (not (string-match str (ring-ref clearcase-comment-ring n))))
1553 (clearcase-comment-previous (- n clearcase-comment-ring-index)))
1554 (t (error "Not found")))))
1560 ;;{{{ Major Mode: for editing config-specs.
1562 ;; The major mode function.
1564 (defun clearcase-edcs-mode ()
1566 (set-syntax-table text-mode-syntax-table)
1567 (use-local-map clearcase-edcs-mode-map)
1568 (setq major-mode 'clearcase-edcs-mode)
1569 (setq mode-name "ClearCase/edcs")
1570 (make-variable-buffer-local 'clearcase-parent-buffer)
1571 (set-buffer-modified-p nil)
1572 (setq buffer-file-name nil)
1573 (run-hooks 'text-mode-hook 'clearcase-edcs-mode-hook))
1577 (defvar clearcase-edcs-mode-map nil)
1578 (if clearcase-edcs-mode-map
1580 (setq clearcase-edcs-mode-map (make-sparse-keymap))
1581 (define-key clearcase-edcs-mode-map "\C-c\C-c" 'clearcase-edcs-finish)
1582 (define-key clearcase-edcs-mode-map "\C-x\C-s" 'clearcase-edcs-save))
1586 (defvar clearcase-edcs-tag-name nil
1587 "Name of view tag which is currently being edited")
1589 (defvar clearcase-edcs-tag-history ()
1590 "History of view tags used in clearcase-edcs-edit")
1594 (defun clearcase-edcs-edit (tag-name)
1595 "Edit a ClearCase configuration specification"
1598 (let ((vxname (clearcase-fprop-viewtag default-directory)))
1599 (if clearcase-complete-viewtags
1600 (list (directory-file-name
1601 (completing-read "View Tag: "
1602 (clearcase-viewtag-all-viewtags-obarray)
1607 'clearcase-edcs-tag-history)))
1608 (read-string "View Tag: "))))
1610 (let ((start (current-buffer))
1611 (buffer-name (format "*clearcase-config-spec-%s*" tag-name)))
1612 (kill-buffer (get-buffer-create buffer-name))
1613 (pop-to-buffer (get-buffer-create buffer-name))
1614 (auto-save-mode auto-save-default)
1616 (insert (clearcase-ct-cleartool-cmd "catcs" "-tag" tag-name))
1617 (goto-char (point-min))
1618 (re-search-forward "^[^#\n]" nil 'end)
1620 (clearcase-edcs-mode)
1621 (setq clearcase-parent-buffer start)
1622 (make-local-variable 'clearcase-edcs-tag-name)
1623 (setq clearcase-edcs-tag-name tag-name)))
1625 (defun clearcase-edcs-save ()
1627 (if (not (buffer-modified-p))
1628 (message "Configuration not changed since last saved")
1630 (message "Setting configuration for %s..." clearcase-edcs-tag-name)
1631 (clearcase-with-tempfile
1633 (write-region (point-min) (point-max) cspec-text nil 'dont-mention-it)
1634 (let ((ret (clearcase-ct-cleartool-cmd "setcs"
1636 clearcase-edcs-tag-name
1637 (clearcase-path-native cspec-text))))
1639 ;; nyi: we could be smarter and retain viewtag info and perhaps some
1640 ;; other info. For now invalidate all cached file property info.
1642 (clearcase-fprop-clear-all-properties)
1644 (set-buffer-modified-p nil)
1645 (message "Setting configuration for %s...done"
1646 clearcase-edcs-tag-name)))))
1648 (defun clearcase-edcs-finish ()
1650 (let ((old-buffer (current-buffer)))
1651 (clearcase-edcs-save)
1653 (kill-buffer old-buffer)))
1661 ;; nyi: Just an idea now.
1662 ;; Be able to present a selection of views at various times
1663 ;; - show me current file in other view
1664 ;; - top-level browse operation
1666 ;; clearcase-viewtag-started-viewtags gives us the dynamic views that are mounted.
1668 ;; How to find local snapshots ?
1670 ;; How to find drive-letter mount points for view on NT ?
1671 ;; - parse "subst" output
1677 ;;{{{ Hijack/unhijack
1679 (defun clearcase-hijack-current-buffer ()
1680 "Hijack the file in the current buffer."
1682 (clearcase-hijack buffer-file-name))
1684 (defun clearcase-hijack-dired-files ()
1685 "Hijack the selected files."
1687 (clearcase-hijack-seq (dired-get-marked-files)))
1689 (defun clearcase-unhijack-current-buffer ()
1690 "Unhijack the file in the current buffer."
1692 (clearcase-unhijack buffer-file-name))
1694 (defun clearcase-unhijack-dired-files ()
1695 "Hijack the selected files."
1697 (clearcase-unhijack-seq (dired-get-marked-files)))
1703 (defun clearcase-annotate-file (file)
1704 (let ((relative-name (file-relative-name file)))
1705 (message "Annotating %s ..." relative-name)
1706 (clearcase-with-tempfile
1708 (clearcase-ct-do-cleartool-command "annotate"
1713 clearcase-annotate-fmt-string
1716 (clearcase-utl-populate-and-view-buffer
1717 "*clearcase-annotate*"
1721 (insert-file-contents annotation-file)))))
1722 (message "Annotating %s ...done" relative-name)))
1724 (defun clearcase-annotate-current-buffer ()
1726 (clearcase-annotate-file buffer-file-name))
1728 (defun clearcase-annotate-dired-file ()
1729 "Annotate the selected file."
1731 (clearcase-annotate-file (dired-get-filename)))
1735 ;;{{{ nyi: Find checkouts
1737 ;; NYI: Enhance this:
1740 ;; - checkout comment
1741 ;; - permit unco/checkin
1743 (defun clearcase-find-checkouts-in-current-view ()
1744 "Find the checkouts in all vobs in the current view."
1746 (let ((viewtag (clearcase-fprop-viewtag default-directory))
1747 (dir default-directory))
1749 (let* ((ignore (message "Finding checkouts..."))
1750 (text (clearcase-ct-blocking-call "lsco"
1754 (if (zerop (length text))
1755 (message "No checkouts found")
1757 (message "Finding checkouts...done")
1759 (clearcase-utl-populate-and-view-buffer
1762 (function (lambda (s)
1767 ;;{{{ UCM operations
1771 (defun clearcase-read-new-activity-name ()
1772 "Read the name of a new activity from the minibuffer.
1773 Return nil if the empty string is entered."
1775 ;; nyi: Probably should check that the activity doesn't already exist.
1777 (let ((entered-name (read-string "Activity name (optional): " )))
1778 (if (not (zerop (length entered-name)))
1782 (defun clearcase-read-mkact-args ()
1783 "Read the name and headline arguments for clearcase-ucm-mkact-current-dir
1784 from the minibuffer."
1788 (if clearcase-prompt-for-activity-names
1789 (setq name (clearcase-read-new-activity-name)))
1790 (setq headline (read-string "Activity headline: " ))
1791 (list name headline)))
1793 (defun clearcase-make-internally-named-activity (stream-name comment-file)
1794 "Make a new activity in STREAM-NAME with creation comment in COMMENT-FILE,
1795 and use an internally-generated name for the activity."
1798 (if clearcase-set-to-new-activity
1799 (clearcase-ct-blocking-call "mkact"
1800 "-cfile" (clearcase-path-native comment-file)
1803 (clearcase-ct-blocking-call "mkact"
1805 "-cfile" (clearcase-path-native comment-file)
1809 (if (string-match "Created activity \"\\([^\"]+\\)\"" ret)
1810 (substring ret (match-beginning 1) (match-end 1))
1811 (error "Failed to create activity: %s" ret))))
1813 (defun clearcase-ucm-mkact-current-dir (name headline &optional comment)
1815 "Make an activity with NAME and HEADLINE and optional COMMENT, in the stream
1816 associated with the view associated with the current directory."
1818 (interactive (clearcase-read-mkact-args))
1819 (let* ((viewtag (clearcase-fprop-viewtag default-directory))
1820 (stream (clearcase-vprop-stream viewtag))
1821 (pvob (clearcase-vprop-pvob viewtag)))
1822 (if (not (clearcase-vprop-ucm viewtag))
1823 (error "View %s is not a UCM view" viewtag))
1825 (error "View %s has no stream" viewtag))
1827 (error "View %s has no PVOB" viewtag))
1830 ;; If no comment supplied, go and get one..
1833 (clearcase-comment-start-entry (format "new-activity-%d" (random))
1834 "Enter comment for new activity."
1835 'clearcase-ucm-mkact-current-dir
1836 (list name headline)))
1837 ;; ...else do the operation.
1839 (message "Making activity...")
1840 (clearcase-with-tempfile
1842 (write-region comment nil comment-file nil 'noprint)
1843 (let ((qualified-stream (format "%s@%s" stream pvob)))
1845 (if clearcase-set-to-new-activity
1846 (clearcase-ct-blocking-call "mkact"
1847 "-cfile" (clearcase-path-native comment-file)
1848 "-headline" headline
1849 "-in" qualified-stream
1852 (clearcase-ct-blocking-call "mkact"
1854 "-cfile" (clearcase-path-native comment-file)
1855 "-headline" headline
1856 "-in" qualified-stream
1860 ;; If no name was provided we do the creation in two steps:
1863 ;; to make sure we get preferred internally generated activity
1864 ;; name of the form "activityNNN.MMM" rather than some horrible
1865 ;; concoction based on the headline.
1867 (let ((name (clearcase-make-internally-named-activity qualified-stream comment-file)))
1868 (clearcase-ct-blocking-call "chact"
1869 "-headline" headline
1872 ;; Flush the activities for this view so they'll get refreshed when needed.
1874 (clearcase-vprop-flush-activities viewtag)
1876 (message "Making activity...done"))))
1882 (defun clearcase-ucm-filter-out-rebases (activities)
1883 (if (not clearcase-hide-rebase-activities)
1885 (clearcase-utl-list-filter
1888 (let ((id (car activity)))
1889 (not (string-match clearcase-rebase-id-regexp id)))))
1892 (defun clearcase-ucm-set-activity-current-dir ()
1894 (let* ((viewtag (clearcase-fprop-viewtag default-directory)))
1895 (if (not (clearcase-vprop-ucm viewtag))
1896 (error "View %s is not a UCM view" viewtag))
1897 ;; Filter out the rebases here if the user doesn't want to see them.
1899 (let ((activities (clearcase-ucm-filter-out-rebases (clearcase-vprop-activities viewtag))))
1900 (if (null activities)
1901 (error "View %s has no activities" viewtag))
1902 (clearcase-ucm-make-selection-window (format "*clearcase-activity-select-%s*" viewtag)
1906 (let ((id (car activity))
1907 (title (cdr activity)))
1908 (format "%s\t%s" id title))))
1911 'clearcase-ucm-activity-selection-interpreter
1912 'clearcase-ucm-set-activity
1915 (defun clearcase-ucm-activity-selection-interpreter ()
1916 "Extract the activity name from the buffer at point"
1917 (if (looking-at "^\\(.*\\)\t")
1918 (let ((activity-name (buffer-substring (match-beginning 1)
1921 (error "No activity on this line")))
1923 (defun clearcase-ucm-set-activity-none-current-dir ()
1925 (let* ((viewtag (clearcase-fprop-viewtag default-directory)))
1926 (if (not (clearcase-vprop-ucm viewtag))
1927 (error "View %s is not a UCM view" viewtag))
1928 (clearcase-ucm-set-activity viewtag nil)))
1930 (defun clearcase-ucm-set-activity (viewtag activity-name)
1935 (message "Setting activity...")
1936 (let ((qualified-activity-name (if (string-match "@" activity-name)
1938 (concat activity-name "@" (clearcase-vprop-pvob viewtag)))))
1939 (clearcase-ct-blocking-call "setactivity" "-nc" "-view"
1941 (if qualified-activity-name
1942 qualified-activity-name
1946 (clearcase-vprop-set-current-activity viewtag activity-name)
1947 (message "Setting activity...done"))
1951 (message "Unsetting activity...")
1952 (clearcase-ct-blocking-call "setactivity"
1958 (clearcase-vprop-set-current-activity viewtag nil)
1959 (message "Unsetting activity...done")))
1963 ;;{{{ Show current activity
1965 (defun clearcase-ucm-describe-current-activity ()
1967 (let* ((viewtag (clearcase-fprop-viewtag default-directory)))
1969 (error "Not in a view"))
1970 (if (not (clearcase-vprop-ucm viewtag))
1971 (error "View %s is not a UCM view" viewtag))
1972 (let ((pvob (clearcase-vprop-pvob viewtag))
1973 (current-activity (clearcase-vprop-current-activity viewtag)))
1974 (if (not current-activity)
1975 (message "No activity set")
1976 (let ((text (clearcase-ct-blocking-call "desc"
1981 (if (not (zerop (length text)))
1982 (clearcase-utl-populate-and-view-buffer
1985 (function (lambda (s)
1993 (defun clearcase-next-action-current-buffer ()
1994 "Do the next logical operation on the current file.
1995 Operations include mkelem, checkout, checkin, uncheckout"
1997 (clearcase-next-action buffer-file-name))
1999 (defun clearcase-next-action-dired-files ()
2000 "Do the next logical operation on the marked files.
2001 Operations include mkelem, checkout, checkin, uncheckout.
2002 If all the files are not in an equivalent state, an error is raised."
2005 (clearcase-next-action-seq (dired-get-marked-files)))
2007 (defun clearcase-next-action (file)
2008 (let ((action (clearcase-compute-next-action file)))
2011 ((eq action 'mkelem)
2012 (clearcase-commented-mkelem file))
2014 ((eq action 'checkout)
2015 (clearcase-commented-checkout file))
2017 ((eq action 'uncheckout)
2018 (if (yes-or-no-p "Checked-out file appears unchanged. Cancel checkout ? ")
2019 (clearcase-uncheckout file)))
2021 ((eq action 'illegal-checkin)
2022 (error "This file is checked out by someone else: %s" (clearcase-fprop-user file)))
2024 ((eq action 'checkin)
2025 (clearcase-commented-checkin file))
2028 (error "Can't compute suitable next ClearCase action for file %s" file)))))
2030 (defun clearcase-next-action-seq (files)
2031 "Do the next logical operation on the sequence of FILES."
2033 ;; Check they're all in the same state.
2035 (let ((actions (mapcar (function clearcase-compute-next-action) files)))
2036 (if (not (clearcase-utl-elts-are-eq actions))
2037 (error "Marked files are not all in the same state"))
2038 (let ((action (car actions)))
2041 ((eq action 'mkelem)
2042 (clearcase-commented-mkelem-seq files))
2044 ((eq action 'checkout)
2045 (clearcase-commented-checkout-seq files))
2047 ((eq action 'uncheckout)
2048 (if (yes-or-no-p "Checked-out files appears unchanged. Cancel checkouts ? ")
2049 (clearcase-uncheckout-seq files)))
2051 ((eq action 'illegal-checkin)
2052 (error "These files are checked out by someone else; will no checkin"))
2054 ((eq action 'checkin)
2055 (clearcase-commented-checkin-seq files))
2058 (error "Can't compute suitable next ClearCase action for marked files"))))))
2060 (defun clearcase-compute-next-action (file)
2061 "Compute the next logical action on FILE."
2064 ;; nyi: other cases to consider later:
2066 ;; - file is unreserved
2067 ;; - file is not mastered
2069 ;; Case 1: it is not yet an element
2072 ((clearcase-file-ok-to-mkelem file)
2075 ;; Case 2: file is not checked out
2078 ((clearcase-file-ok-to-checkout file)
2081 ;; Case 3: file is checked-out but not modified in buffer or disk
2082 ;; ==> offer to uncheckout
2084 ((and (clearcase-file-ok-to-uncheckout file)
2085 (not (file-directory-p file))
2086 (not (buffer-modified-p))
2087 (not (clearcase-file-appears-modified-since-checkout-p file)))
2090 ;; Case 4: file is checked-out but by somebody else using this view.
2091 ;; ==> refuse to checkin
2093 ;; This is not reliable on some Windows installations where a user is known
2094 ;; as "esler" on Unix and the ClearCase server, and "ESLER" on the Windows
2097 ((and (not clearcase-on-mswindows)
2098 (clearcase-fprop-checked-out file)
2099 (not (string= (user-login-name)
2100 (clearcase-fprop-user file))))
2103 ;; Case 5: user has checked-out the file
2106 ((clearcase-file-ok-to-checkin file)
2116 (defun clearcase-mkelem-current-buffer ()
2117 "Make the current file into a ClearCase element."
2120 ;; Watch out for new buffers of size 0: the corresponding file
2121 ;; does not exist yet, even though buffer-modified-p is nil.
2123 (if (and (not (buffer-modified-p))
2124 (zerop (buffer-size))
2125 (not (file-exists-p buffer-file-name)))
2126 (set-buffer-modified-p t))
2128 (clearcase-commented-mkelem buffer-file-name))
2130 (defun clearcase-mkelem-dired-files ()
2131 "Make the selected files into ClearCase elements."
2133 (clearcase-commented-mkelem-seq (dired-get-marked-files)))
2139 (defun clearcase-checkin-current-buffer ()
2140 "Checkin the file in the current buffer."
2143 ;; Watch out for new buffers of size 0: the corresponding file
2144 ;; does not exist yet, even though buffer-modified-p is nil.
2146 (if (and (not (buffer-modified-p))
2147 (zerop (buffer-size))
2148 (not (file-exists-p buffer-file-name)))
2149 (set-buffer-modified-p t))
2151 (clearcase-commented-checkin buffer-file-name))
2153 (defun clearcase-checkin-dired-files ()
2154 "Checkin the selected files."
2156 (clearcase-commented-checkin-seq (dired-get-marked-files)))
2158 (defun clearcase-dired-checkin-current-dir ()
2160 (clearcase-commented-checkin (dired-current-directory)))
2164 ;;{{{ Edit checkout comment
2166 (defun clearcase-edit-checkout-comment-current-buffer ()
2167 "Edit the clearcase comment for the checked-out file in the current buffer."
2169 (clearcase-edit-checkout-comment buffer-file-name))
2171 (defun clearcase-edit-checkout-comment-dired-file ()
2172 "Checkin the selected file."
2174 (clearcase-edit-checkout-comment (dired-get-filename)))
2176 (defun clearcase-edit-checkout-comment (file &optional comment)
2177 "Edit comment for FILE by popping up a buffer to accept one. If COMMENT
2178 is specified, save it."
2180 ;; If no comment supplied, go and get one...
2182 (clearcase-comment-start-entry (file-name-nondirectory file)
2183 "Edit the file's check-out comment."
2184 'clearcase-edit-checkout-comment
2185 (list buffer-file-name)
2186 (find-file-noselect file)
2187 (clearcase-fprop-comment file))
2188 ;; We have a comment, save it
2189 (clearcase-comment-save-comment-for-buffer comment clearcase-parent-buffer)))
2195 (defun clearcase-checkout-current-buffer ()
2196 "Checkout the file in the current buffer."
2198 (clearcase-commented-checkout buffer-file-name))
2200 (defun clearcase-checkout-dired-files ()
2201 "Checkout the selected files."
2203 (clearcase-commented-checkout-seq (dired-get-marked-files)))
2205 (defun clearcase-dired-checkout-current-dir ()
2207 (clearcase-commented-checkout (dired-current-directory)))
2213 (defun clearcase-uncheckout-current-buffer ()
2214 "Uncheckout the file in the current buffer."
2216 (clearcase-uncheckout buffer-file-name))
2218 (defun clearcase-uncheckout-dired-files ()
2219 "Uncheckout the selected files."
2221 (clearcase-uncheckout-seq (dired-get-marked-files)))
2223 (defun clearcase-dired-uncheckout-current-dir ()
2225 (clearcase-uncheckout (dired-current-directory)))
2231 (defun clearcase-mkbrtype (typename)
2232 (interactive "sBranch type name: ")
2233 (clearcase-commented-mkbrtype typename))
2239 (defun clearcase-describe-current-buffer ()
2240 "Give a ClearCase description of the file in the current buffer."
2242 (clearcase-describe buffer-file-name))
2244 (defun clearcase-describe-dired-file ()
2245 "Describe the selected files."
2247 (clearcase-describe (dired-get-filename)))
2253 (defun clearcase-what-rule-current-buffer ()
2255 (clearcase-what-rule buffer-file-name))
2257 (defun clearcase-what-rule-dired-file ()
2259 (clearcase-what-rule (dired-get-filename)))
2265 (defun clearcase-list-history-current-buffer ()
2266 "List the change history of the current buffer in a window."
2268 (clearcase-list-history buffer-file-name))
2270 (defun clearcase-list-history-dired-file ()
2271 "List the change history of the current file."
2273 (clearcase-list-history (dired-get-filename)))
2279 (defun clearcase-ediff-pred-current-buffer ()
2280 "Use Ediff to compare a version in the current buffer against its predecessor."
2282 (clearcase-ediff-file-with-version buffer-file-name
2283 (clearcase-fprop-predecessor-version buffer-file-name)))
2285 (defun clearcase-ediff-pred-dired-file ()
2286 "Use Ediff to compare the selected version against its predecessor."
2288 (let ((truename (clearcase-fprop-truename (dired-get-filename))))
2289 (clearcase-ediff-file-with-version truename
2290 (clearcase-fprop-predecessor-version truename))))
2292 (defun clearcase-ediff-branch-base-current-buffer()
2293 "Use Ediff to compare a version in the current buffer
2294 against the base of its branch."
2296 (clearcase-ediff-file-with-version buffer-file-name
2297 (clearcase-vxpath-version-of-branch-base buffer-file-name)))
2299 (defun clearcase-ediff-branch-base-dired-file()
2300 "Use Ediff to compare the selected version against the base of its branch."
2302 (let ((truename (clearcase-fprop-truename (dired-get-filename))))
2303 (clearcase-ediff-file-with-version truename
2304 (clearcase-vxpath-version-of-branch-base truename))))
2306 (defun clearcase-ediff-named-version-current-buffer (version)
2307 ;; nyi: if we're in history-mode, probably should just use
2310 (interactive (list (clearcase-read-version-name "Version for comparison: "
2312 (clearcase-ediff-file-with-version buffer-file-name version))
2314 (defun clearcase-ediff-named-version-dired-file (version)
2315 ;; nyi: if we're in history-mode, probably should just use
2318 (interactive (list (clearcase-read-version-name "Version for comparison: "
2319 (dired-get-filename))))
2320 (clearcase-ediff-file-with-version (clearcase-fprop-truename (dired-get-filename))
2323 (defun clearcase-ediff-file-with-version (truename other-version)
2324 (let ((other-vxpath (clearcase-vxpath-cons-vxpath (clearcase-vxpath-element-part truename)
2326 (if (clearcase-file-is-in-mvfs-p truename)
2327 (ediff-files other-vxpath truename)
2328 (ediff-buffers (clearcase-vxpath-get-version-in-buffer other-vxpath)
2329 (find-file-noselect truename t)))))
2335 (defun clearcase-gui-diff-pred-current-buffer ()
2336 "Use GUI to compare a version in the current buffer against its predecessor."
2338 (clearcase-gui-diff-file-with-version buffer-file-name
2339 (clearcase-fprop-predecessor-version buffer-file-name)))
2341 (defun clearcase-gui-diff-pred-dired-file ()
2342 "Use GUI to compare the selected version against its predecessor."
2344 (let ((truename (clearcase-fprop-truename (dired-get-filename))))
2345 (clearcase-gui-diff-file-with-version truename
2346 (clearcase-fprop-predecessor-version truename))))
2348 (defun clearcase-gui-diff-branch-base-current-buffer()
2349 "Use GUI to compare a version in the current buffer
2350 against the base of its branch."
2352 (clearcase-gui-diff-file-with-version buffer-file-name
2353 (clearcase-vxpath-version-of-branch-base buffer-file-name)))
2355 (defun clearcase-gui-diff-branch-base-dired-file()
2356 "Use GUI to compare the selected version against the base of its branch."
2358 (let ((truename (clearcase-fprop-truename (dired-get-filename))))
2359 (clearcase-gui-diff-file-with-version truename
2360 (clearcase-vxpath-version-of-branch-base truename))))
2362 (defun clearcase-gui-diff-named-version-current-buffer (version)
2363 ;; nyi: if we're in history-mode, probably should just use
2366 (interactive (list (clearcase-read-version-name "Version for comparison: "
2368 (clearcase-gui-diff-file-with-version buffer-file-name version))
2370 (defun clearcase-gui-diff-named-version-dired-file (version)
2371 ;; nyi: if we're in history-mode, probably should just use
2374 (interactive (list (clearcase-read-version-name "Version for comparison: "
2375 (dired-get-filename))))
2376 (clearcase-gui-diff-file-with-version (clearcase-fprop-truename (dired-get-filename))
2379 (defun clearcase-gui-diff-file-with-version (truename other-version)
2380 (let* ((other-vxpath (clearcase-vxpath-cons-vxpath (clearcase-vxpath-element-part truename)
2382 (other-file (if (clearcase-file-is-in-mvfs-p truename)
2384 (clearcase-vxpath-get-version-in-temp-file other-vxpath)))
2385 (gui-name (if clearcase-on-mswindows
2388 (start-process "Diff"
2391 (clearcase-path-native other-file)
2392 (clearcase-path-native truename))))
2398 (defun clearcase-diff-pred-current-buffer ()
2399 "Use Diff to compare a version in the current buffer against its predecessor."
2401 (clearcase-diff-file-with-version buffer-file-name
2402 (clearcase-fprop-predecessor-version buffer-file-name)))
2404 (defun clearcase-diff-pred-dired-file ()
2405 "Use Diff to compare the selected version against its predecessor."
2407 (let ((truename (clearcase-fprop-truename (dired-get-filename))))
2408 (clearcase-diff-file-with-version truename
2409 (clearcase-fprop-predecessor-version truename))))
2411 (defun clearcase-diff-branch-base-current-buffer()
2412 "Use Diff to compare a version in the current buffer
2413 against the base of its branch."
2415 (clearcase-diff-file-with-version buffer-file-name
2416 (clearcase-vxpath-version-of-branch-base buffer-file-name)))
2418 (defun clearcase-diff-branch-base-dired-file()
2419 "Use Diff to compare the selected version against the base of its branch."
2421 (let ((truename (clearcase-fprop-truename (dired-get-filename))))
2422 (clearcase-diff-file-with-version truename
2423 (clearcase-vxpath-version-of-branch-base truename))))
2425 (defun clearcase-diff-named-version-current-buffer (version)
2426 ;; nyi: if we're in history-mode, probably should just use
2429 (interactive (list (clearcase-read-version-name "Version for comparison: "
2431 (clearcase-diff-file-with-version buffer-file-name version))
2433 (defun clearcase-diff-named-version-dired-file (version)
2434 ;; nyi: if we're in history-mode, probably should just use
2437 (interactive (list (clearcase-read-version-name "Version for comparison: "
2438 (dired-get-filename))))
2439 (clearcase-diff-file-with-version (clearcase-fprop-truename (dired-get-filename))
2442 (defun clearcase-diff-file-with-version (truename other-version)
2443 (let ((other-vxpath (clearcase-vxpath-cons-vxpath (clearcase-vxpath-element-part truename)
2445 (if (clearcase-file-is-in-mvfs-p truename)
2446 (clearcase-diff-files other-vxpath truename)
2447 (clearcase-diff-files (clearcase-vxpath-get-version-in-temp-file other-vxpath)
2454 (defun clearcase-version-other-window (version)
2457 (clearcase-read-version-name (format "Version of %s to visit: "
2458 (file-name-nondirectory buffer-file-name))
2460 (find-file-other-window (clearcase-vxpath-cons-vxpath
2461 (clearcase-vxpath-element-part buffer-file-name)
2464 (defun clearcase-browse-vtree-current-buffer (&optional graphical)
2465 "Browse vtree of ClearCase element in current buffer. Uses Dired Mode unless a
2466 prefix argument is givem in which case the GUI vtree tool is invoked."
2468 (clearcase-browse-vtree buffer-file-name graphical))
2470 (defun clearcase-browse-vtree-dired-file (&optional graphical)
2471 "Browse vtree of ClearCase element selected in current dired buffer. Uses Dired Mode unless a
2472 prefix argument is givem in which case the GUI vtree tool is invoked."
2474 (clearcase-browse-vtree (dired-get-filename) graphical))
2480 (defun clearcase-gui-vtree-browser-current-buffer ()
2482 (clearcase-gui-vtree-browser buffer-file-name))
2484 (defun clearcase-gui-vtree-browser-dired-file ()
2486 (clearcase-gui-vtree-browser (dired-get-filename)))
2488 (defun clearcase-gui-vtree-browser (file)
2489 (let ((gui-name (if clearcase-on-mswindows
2492 (start-process "Vtree_browser"
2495 (clearcase-path-native file))))
2501 (defun clearcase-gui-clearexplorer ()
2503 (start-process "ClearExplorer"
2508 (defun clearcase-gui-rebase ()
2510 (start-process "Rebase"
2513 (if clearcase-on-mswindows
2517 (defun clearcase-gui-deliver ()
2519 (start-process "Deliver"
2522 (if clearcase-on-mswindows
2526 (defun clearcase-gui-merge-manager ()
2528 (start-process "Merge_manager"
2532 (defun clearcase-gui-project-explorer ()
2534 (start-process "Project_explorer"
2538 (defun clearcase-gui-snapshot-view-updater ()
2540 (start-process "View_updater"
2546 ;;{{{ Update snapshot
2548 ;; In a file buffer:
2549 ;; - update current-file
2550 ;; - update directory
2553 ;; - update marked files
2556 ;; We allow several simultaneous updates, but only one per view.
2558 (defun clearcase-update-view ()
2560 (clearcase-update (clearcase-fprop-viewtag default-directory)))
2562 (defun clearcase-update-default-directory ()
2564 (clearcase-update (clearcase-fprop-viewtag default-directory)
2567 (defun clearcase-update-current-buffer ()
2569 (clearcase-update (clearcase-fprop-viewtag default-directory)
2572 (defun clearcase-update-dired-files ()
2574 (apply (function clearcase-update)
2575 (cons (clearcase-fprop-viewtag default-directory)
2576 (dired-get-marked-files))))
2581 ;;{{{ Sync all buffers
2582 (defun clearcase-sync-all-buffers ()
2583 "Synchronize clearcase information for all clearcase buffers if needed."
2585 (mapcar (lambda (buf)
2586 (let* ((file (buffer-file-name buf))
2587 (version (when file (clearcase-fprop-version file))))
2588 (when (and file version (not (equal version "")))
2589 (clearcase-sync-from-disk-if-needed file))))
2592 (defun clearcase-sync-file-if-needed ()
2593 "Function to be run from a hook to synchronize with clearcase.
2595 Intended to be used with the auto-revert hook 'auto-revert-buffer-reverted-hook"
2596 (let ((filename (buffer-file-name)))
2598 (clearcase-sync-from-disk-if-needed filename))))
2606 ;;{{{ Basic ClearCase operations
2608 ;;{{{ Update snapshot view
2610 ;;{{{ Asynchronous post-processing of update
2612 (defvar clearcase-post-update-timer nil)
2613 (defvar clearcase-post-update-work-queue nil)
2615 (defun clearcase-post-update-schedule-work (buffer)
2616 (clearcase-trace "entering clearcase-post-update-schedule-work")
2617 ;; Add to the work queue.
2619 (setq clearcase-post-update-work-queue (cons buffer
2620 clearcase-post-update-work-queue))
2621 ;; Create the timer if necessary.
2623 (if (null clearcase-post-update-timer)
2624 (if clearcase-xemacs-p
2627 (setq clearcase-post-update-timer
2628 (run-with-idle-timer 2 t 'clearcase-post-update-timer-function))
2632 (setq clearcase-post-update-timer (timer-create))
2633 (timer-set-function clearcase-post-update-timer 'clearcase-post-update-timer-function)
2634 (timer-set-idle-time clearcase-post-update-timer 2)
2635 (timer-activate-when-idle clearcase-post-update-timer)))
2636 (clearcase-trace "clearcase-post-update-schedule-work: post-update timer found to be non-null")))
2639 (defun clearcase-post-update-timer-function ()
2640 (clearcase-trace "Entering clearcase-post-update-timer-function")
2641 ;; For (each update-process buffer in the work queue)
2642 ;; if (its process has successfully terminated)
2643 ;; do the post-processing for this update
2644 ;; remove it from the work queue
2646 (clearcase-trace (format "Queue before: %s" clearcase-post-update-work-queue))
2647 (setq clearcase-post-update-work-queue
2649 (clearcase-utl-list-filter
2650 (function clearcase-post-update-check-process-buffer)
2651 clearcase-post-update-work-queue))
2653 (clearcase-trace (format "Queue after: %s" clearcase-post-update-work-queue))
2654 ;; If the work queue is now empty cancel the timer.
2656 (if (null clearcase-post-update-work-queue)
2658 (if clearcase-xemacs-p
2659 (delete-itimer clearcase-post-update-timer)
2660 (cancel-timer clearcase-post-update-timer))
2661 (setq clearcase-post-update-timer nil))))
2663 (defun clearcase-post-update-check-process-buffer (buffer)
2664 (clearcase-trace "Entering clearcase-post-update-check-process-buffer")
2666 ;; return t for those buffers that should remain in the work queue
2668 ;; if it has terminated successfully
2669 ;; go sync buffers on the files that were updated
2671 ;; We want to field errors here and when they occurm return nil to avoid a
2674 ;;(condition-case nil
2677 (let ((proc (get-buffer-process buffer)))
2679 ;; Process still exists so keep this on the work queue.
2682 (clearcase-trace "Update process still exists")
2685 ;; Process no longer there, cleaned up by comint code.
2688 ;; Sync any buffers that need it.
2690 (clearcase-trace "Update process finished")
2691 (clearcase-sync-after-scopes-updated (with-current-buffer buffer
2692 ;; Evaluate buffer-local variable.
2694 clearcase-update-buffer-scopes))
2696 ;; Remove from work queue
2700 ;; Error occurred, make sure we return nil to remove the buffer from the
2701 ;; work queue, or a loop could develop.
2706 (defun clearcase-sync-after-scopes-updated (scopes)
2707 (clearcase-trace "Entering clearcase-sync-after-scopes-updated")
2709 ;; nyi: reduce scopes to minimal set of disjoint scopes
2711 ;; Use dynamic binding here since we don't have lexical binding.
2713 (let ((clearcase-dynbound-updated-scopes scopes))
2715 ;; For all buffers...
2720 (let ((visited-file (buffer-file-name buffer)))
2722 (if (clearcase-path-file-in-any-scopes visited-file
2723 clearcase-dynbound-updated-scopes)
2724 ;; This buffer visits a file within an updated scope.
2725 ;; Sync it from disk if it needs it.
2727 (clearcase-sync-from-disk-if-needed visited-file))
2729 ;; Buffer is not visiting a file. If it is a dired-mode buffer
2730 ;; under one of the scopes, revert it.
2732 (with-current-buffer buffer
2733 (if (eq 'dired-mode major-mode)
2734 (if (clearcase-path-file-in-any-scopes default-directory
2735 clearcase-dynbound-updated-scopes)
2736 (dired-revert nil t))))))))
2741 ;; Silence compiler complaints about free variable.
2743 (defvar clearcase-update-buffer-viewtag nil)
2745 (defun clearcase-update (viewtag &rest files)
2746 "Run a cleartool+update process in VIEWTAG
2747 if there isn't one already running in that view.
2748 Other arguments FILES indicate files to update"
2750 ;; Check that there is no update process running in that view.
2752 (if (apply (function clearcase-utl-or-func)
2753 (mapcar (function (lambda (proc)
2754 (if (not (eq 'exit (process-status proc)))
2755 (let ((buf (process-buffer proc)))
2757 (assq 'clearcase-update-buffer-viewtag
2758 (buffer-local-variables buf))
2762 clearcase-update-buffer-viewtag)))))))
2764 (error "There is already an update running in view %s" viewtag))
2767 ;; - create a process in a buffer
2768 ;; - rename the buffer to be of the form *clearcase-update*<N>
2769 ;; - mark it as one of ours by setting clearcase-update-buffer-viewtag
2771 (pop-to-buffer (apply (function make-comint)
2772 (append (list "*clearcase-update-temp-name*"
2773 clearcase-cleartool-path
2778 (rename-buffer "*clearcase-update*" t)
2780 ;; Store in this buffer what view was being updated and what files.
2782 (set (make-local-variable 'clearcase-update-buffer-viewtag) viewtag)
2783 (set (make-local-variable 'clearcase-update-buffer-scopes) files)
2785 ;; nyi: schedule post-update buffer syncing
2786 (clearcase-post-update-schedule-work (current-buffer)))
2792 (defun clearcase-file-ok-to-hijack (file)
2794 "Test if FILE is suitable for hijack."
2798 ;; If it is writeable already, no need to offer a hijack operation, even
2799 ;; though, according to ClearCase, it may not yet be hijacked.
2801 ;;(not (file-writable-p file))
2803 (not (clearcase-fprop-hijacked file))
2804 (clearcase-file-is-in-view-p file)
2805 (not (clearcase-file-is-in-mvfs-p file))
2806 (eq 'version (clearcase-fprop-mtype file))
2807 (not (clearcase-fprop-checked-out file))))
2809 (defun clearcase-hijack-seq (files)
2812 (message "Hijacking...")
2816 (if (not (file-directory-p file))
2817 (clearcase-hijack file))))
2821 (message "Hijacking...done")))
2823 (defun clearcase-hijack (file)
2826 ;; - buffer/files modtimes are equal
2827 ;; - file more recent
2829 ;; - buffer more recent
2830 ;; ==> make file writeable; save buffer ?
2833 ;; - file is hijacked wrt. CC
2834 ;; - buffer is in sync with disk contents, modtime and writeability
2835 ;; except if the user refused to save
2837 (if (not (file-writable-p file))
2838 ;; Make it writeable.
2840 (clearcase-utl-make-writeable file))
2842 ;; Attempt to modify the modtime of the file on disk, otherwise ClearCase
2843 ;; won't actually deem it hijacked. This will silently fail if there is no
2844 ;; "touch" command command available.
2846 (clearcase-utl-touch-file file)
2848 ;; Sync up any buffers.
2850 (clearcase-sync-from-disk file t))
2856 (defun clearcase-file-ok-to-unhijack (file)
2857 "Test if FILE is suitable for unhijack."
2858 (clearcase-fprop-hijacked file))
2860 (defun clearcase-unhijack (file)
2861 (clearcase-unhijack-seq (list file)))
2863 (defun cleartool-unhijack-parse-for-kept-files (ret snapshot-view-root)
2864 ;; Look for occurrences of:
2865 ;; Loading "source\emacs\.emacs.el" (296690 bytes).
2866 ;; (renaming original hijacked object to ".emacs.el.keep.10").
2870 (while (string-match
2871 "^Loading \"\\([^\"]+\\)\"[^\n]+\n(renaming original hijacked object to \"\\([^\"]+\\)\")\\.\n"
2874 (let* ((elt-path (substring ret (match-beginning 1) (match-end 1)))
2875 (abs-elt-path (concat (if snapshot-view-root
2879 (abs-elt-dir (file-name-directory abs-elt-path ))
2880 (kept-file-rel (concat abs-elt-dir
2881 (substring ret (match-beginning 2) (match-end 2))))
2883 ;; This is necessary on Windows to get an absolute path, i.e. one
2884 ;; with a drive letter. Note: probably only correct if
2885 ;; unhijacking files in a single snapshot view, mounted on a
2888 (kept-file (expand-file-name kept-file-rel)))
2889 (setq kept-files (cons kept-file kept-files)))
2890 (setq start (match-end 0)))
2893 (defun clearcase-utl-files-in-same-view-p (files)
2894 (if (< (length files) 2)
2896 (let ((v0 (clearcase-fprop-viewtag (nth 0 files)))
2897 (v1 (clearcase-fprop-viewtag (nth 1 files))))
2898 (if (or (not (stringp v0))
2900 (not (string= v0 v1)))
2902 (clearcase-utl-files-in-same-view-p (cdr files))))))
2904 (defun clearcase-unhijack-seq (files)
2906 ;; Check: there are no directories involved.
2911 (if (file-directory-p file)
2912 (error "Cannot unhijack a directory"))))
2915 ;; Check: all files are in the same snapshot view.
2917 ;; (Why ? The output from ct+update only has view-root-relative paths
2918 ;; and we need to obtain absolute paths of renamed-aside hijacks if we are to
2919 ;; dired-relist them.)
2921 ;; Alternative: partition the set, with each partition containing elements in
2924 (if (not (clearcase-utl-files-in-same-view-p files))
2925 (error "Can't unhijack files in different views in the same operation"))
2927 ;; Run the scoped workspace update synchronously.
2931 (message "Unhijacking...")
2932 (let* ((ret (apply (function clearcase-ct-blocking-call)
2933 (append (list "update"
2934 (if clearcase-keep-unhijacks
2937 "-log" clearcase-sink-file-name)
2939 (snapshot-view-root (clearcase-file-snapshot-root (car files)))
2941 ;; Scan for renamed-aside files.
2943 (kept-files (if clearcase-keep-unhijacks
2944 (cleartool-unhijack-parse-for-kept-files ret
2948 ;; Do post-update synchronisation.
2951 (function clearcase-sync-after-file-updated-from-vob)
2954 ;; Update any dired buffers as to the existence of the kept files.
2956 (if clearcase-keep-unhijacks
2959 (dired-relist-file file)))
2963 (message "Unhijacking...done")))
2969 (defun clearcase-file-ok-to-mkelem (file)
2970 "Test if FILE is okay to mkelem."
2971 (let ((mtype (clearcase-fprop-mtype file)))
2972 (and (not (file-directory-p file))
2973 (and (or (equal 'view-private-object mtype)
2974 (equal 'derived-object mtype))
2975 (not (clearcase-fprop-hijacked file))
2976 (not (clearcase-file-covers-element-p file))))))
2978 (defun clearcase-assert-file-ok-to-mkelem (file)
2979 "Raise an exception if FILE is not suitable for mkelem."
2980 (if (not (clearcase-file-ok-to-mkelem file))
2981 (error "%s cannot be made into an element" file)))
2983 (defun clearcase-commented-mkelem (file &optional okay-to-checkout-dir-first comment)
2984 "Create a new element from FILE. If OKAY-TO-CHECKOUT-DIR-FIRST is non-nil,
2985 the containing directory will be checked out if necessary.
2986 If COMMENT is non-nil, it will be used, otherwise the user will be prompted
2991 (clearcase-assert-file-ok-to-mkelem file)
2993 (let ((containing-dir (file-name-directory file)))
2997 (if (not (eq 'directory-version (clearcase-fprop-mtype containing-dir)))
2998 (error "Parent directory of %s is not a ClearCase versioned directory."
3001 ;; Determine if we'll need to checkout the parent directory first.
3003 (let ((dir-checkout-needed (not (clearcase-fprop-checked-out containing-dir))))
3004 (if dir-checkout-needed
3006 ;; Parent dir will need to be checked out. Get permission if
3009 (if (null okay-to-checkout-dir-first)
3010 (setq okay-to-checkout-dir-first
3011 (or (null clearcase-verify-pre-mkelem-dir-checkout)
3012 (y-or-n-p (format "Checkout directory %s " containing-dir)))))
3013 (if (null okay-to-checkout-dir-first)
3014 (error "Can't make an element unless directory is checked-out."))))
3017 ;; If no comment supplied, go and get one...
3019 (clearcase-comment-start-entry (file-name-nondirectory file)
3020 "Enter initial comment for the new element."
3021 'clearcase-commented-mkelem
3022 (list file okay-to-checkout-dir-first)
3023 (find-file-noselect file)
3024 clearcase-initial-mkelem-comment)
3026 ;; ...otherwise perform the operation.
3029 ;; We may need to checkout the directory.
3031 (if dir-checkout-needed
3032 (clearcase-commented-checkout containing-dir comment))
3034 (clearcase-fprop-unstore-properties file)
3036 (message "Making element %s..." file)
3039 ;; Sync the buffer to disk.
3041 (let ((buffer-on-file (find-buffer-visiting file)))
3044 (set-buffer buffer-on-file)
3045 (clearcase-sync-to-disk))))
3047 (clearcase-ct-do-cleartool-command "mkelem"
3050 (if clearcase-checkin-on-mkelem
3052 (message "Making element %s...done" file)
3056 (clearcase-sync-from-disk file t))))))
3058 (defun clearcase-commented-mkelem-seq (files &optional comment)
3059 "Mkelem a sequence of FILES. If COMMENT is supplied it will be
3060 used, otherwise the user will be prompted to enter one."
3063 (function clearcase-assert-file-ok-to-mkelem)
3067 ;; No comment supplied, go and get one...
3069 (clearcase-comment-start-entry "mkelem"
3070 "Enter comment for elements' creation"
3071 'clearcase-commented-mkelem-seq
3073 ;; ...otherwise operate.
3078 (clearcase-commented-mkelem file nil comment)))
3085 (defun clearcase-file-ok-to-checkin (file)
3086 "Test if FILE is suitable for checkin."
3087 (let ((me (user-login-name)))
3088 (equal me (clearcase-fprop-owner-of-checkout file))))
3090 (defun clearcase-assert-file-ok-to-checkin (file)
3091 "Raise an exception if FILE is not suitable for checkin."
3092 (if (not (clearcase-file-ok-to-checkin file))
3093 (error "You cannot checkin %s" file)))
3095 (defun clearcase-commented-checkin (file &optional comment)
3096 "Check-in FILE with COMMENT. If the comment is omitted,
3097 a buffer is popped up to accept one."
3099 (clearcase-assert-file-ok-to-checkin file)
3102 ;; If no comment supplied, go and get one..
3105 (clearcase-comment-start-entry (file-name-nondirectory file)
3106 "Enter a checkin comment."
3107 'clearcase-commented-checkin
3109 (find-file-noselect file)
3110 (clearcase-fprop-comment file))
3112 ;; Also display a diff, if that is the custom:
3114 (if (and (not (file-directory-p file))
3115 clearcase-diff-on-checkin)
3117 (let ((tmp-buffer (current-buffer)))
3118 (message "Running diff...")
3119 (clearcase-diff-file-with-version file
3120 (clearcase-fprop-predecessor-version file))
3121 (message "Running diff...done")
3122 (set-buffer "*clearcase*")
3123 (if (get-buffer "*clearcase-diff*")
3124 (kill-buffer "*clearcase-diff*"))
3125 (rename-buffer "*clearcase-diff*")
3126 (pop-to-buffer tmp-buffer)))))
3128 ;; ...otherwise perform the operation.
3130 (message "Checking in %s..." file)
3132 ;; Sync the buffer to disk, and get local value of clearcase-checkin-arguments
3134 (let ((buffer-on-file (find-buffer-visiting file)))
3137 (set-buffer buffer-on-file)
3138 (clearcase-sync-to-disk))))
3139 (clearcase-ct-do-cleartool-command "ci"
3142 clearcase-checkin-arguments))
3143 (message "Checking in %s...done" file)
3147 (clearcase-sync-from-disk file t)))
3149 (defun clearcase-commented-checkin-seq (files &optional comment)
3150 "Checkin a sequence of FILES. If COMMENT is supplied it will be
3151 used, otherwise the user will be prompted to enter one."
3153 ;; Check they're all in the right state to be checked-in.
3156 (function clearcase-assert-file-ok-to-checkin)
3160 ;; No comment supplied, go and get one...
3162 (clearcase-comment-start-entry "checkin"
3163 "Enter checkin comment."
3164 'clearcase-commented-checkin-seq
3166 ;; ...otherwise operate.
3171 (clearcase-commented-checkin file comment)))
3178 (defun clearcase-file-ok-to-checkout (file)
3179 "Test if FILE is suitable for checkout."
3180 (let ((mtype (clearcase-fprop-mtype file)))
3181 (and (or (eq 'version mtype)
3182 (eq 'directory-version mtype)
3183 (clearcase-fprop-hijacked file))
3184 (not (clearcase-fprop-checked-out file)))))
3186 (defun clearcase-assert-file-ok-to-checkout (file)
3187 "Raise an exception if FILE is not suitable for checkout."
3188 (if (not (clearcase-file-ok-to-checkout file))
3189 (error "You cannot checkout %s" file)))
3191 ;; nyi: Offer to setact if appropriate
3193 (defun clearcase-commented-checkout (file &optional comment)
3194 "Check-out FILE with COMMENT. If the comment is omitted,
3195 a buffer is popped up to accept one."
3197 (clearcase-assert-file-ok-to-checkout file)
3199 (if (and (null comment)
3200 (not clearcase-suppress-checkout-comments))
3201 ;; If no comment supplied, go and get one...
3203 (clearcase-comment-start-entry (file-name-nondirectory file)
3204 "Enter a checkout comment."
3205 'clearcase-commented-checkout
3207 (find-file-noselect file))
3209 ;; ...otherwise perform the operation.
3211 (message "Checking out %s..." file)
3212 ;; Change buffers to get local value of clearcase-checkin-arguments.
3215 (set-buffer (or (find-buffer-visiting file)
3217 (clearcase-ct-do-cleartool-command "co"
3220 clearcase-checkout-arguments))
3221 (message "Checking out %s...done" file)
3225 (clearcase-sync-from-disk file t)))
3228 (defun clearcase-commented-checkout-seq (files &optional comment)
3229 "Checkout a sequence of FILES. If COMMENT is supplied it will be
3230 used, otherwise the user will be prompted to enter one."
3233 (function clearcase-assert-file-ok-to-checkout)
3236 (if (and (null comment)
3237 (not clearcase-suppress-checkout-comments))
3238 ;; No comment supplied, go and get one...
3240 (clearcase-comment-start-entry "checkout"
3241 "Enter a checkout comment."
3242 'clearcase-commented-checkout-seq
3244 ;; ...otherwise operate.
3249 (clearcase-commented-checkout file comment)))
3256 (defun clearcase-file-ok-to-uncheckout (file)
3257 "Test if FILE is suitable for uncheckout."
3258 (equal (user-login-name)
3259 (clearcase-fprop-owner-of-checkout file)))
3261 (defun clearcase-assert-file-ok-to-uncheckout (file)
3262 "Raise an exception if FILE is not suitable for uncheckout."
3263 (if (not (clearcase-file-ok-to-uncheckout file))
3264 (error "You cannot uncheckout %s" file)))
3266 (defun cleartool-unco-parse-for-kept-file (ret)
3267 ;;Private version of "foo" saved in "foo.keep.1"
3268 (if (string-match "^Private version of .* saved in \"\\([^\"]+\\)\"\\.$" ret)
3269 (substring ret (match-beginning 1) (match-end 1))
3272 (defun clearcase-uncheckout (file)
3275 (clearcase-assert-file-ok-to-uncheckout file)
3277 ;; If it has changed since checkout, insist the user confirm.
3279 (if (and (not (file-directory-p file))
3280 (clearcase-file-appears-modified-since-checkout-p file)
3281 (not clearcase-suppress-confirm)
3282 (not (yes-or-no-p (format "Really discard changes to %s ?" file))))
3283 (message "Uncheckout of %s cancelled" file)
3285 ;; Go ahead and unco.
3287 (message "Cancelling checkout of %s..." file)
3289 ;; - Prompt for -keep or -rm
3290 ;; - offer to remove /0 branches
3292 (let* ((ret (clearcase-ct-blocking-call "unco"
3293 (if clearcase-keep-uncheckouts
3297 ;; Discover the name of the saved.
3299 (kept-file (if clearcase-keep-uncheckouts
3300 (cleartool-unco-parse-for-kept-file ret)
3304 (message "Checkout of %s cancelled (saved in %s)"
3306 (file-name-nondirectory kept-file))
3307 (message "Cancelling checkout of %s...done" file))
3309 ;; Sync any buffers over the file itself.
3311 (clearcase-sync-from-disk file t)
3313 ;; now remove the branch type if the remaining version is 0
3314 (let* ((version (clearcase-fprop-version file))
3315 (full-version (clearcase-vxpath-cons-vxpath file (file-name-directory version))))
3317 (when (and clearcase-remove-branch-after-unheckout-when-only-0-version
3318 (string= (file-name-nondirectory version) "0")
3319 (y-or-n-p (format "Remove branch `%s'?" full-version)))
3320 ;; remove branch type and re-sync any buffers over the file itself.
3321 (clearcase-ct-cleartool-cmd "rmbranch" "-force" full-version)
3322 (clearcase-sync-from-disk file t)))
3324 ;; Update any dired buffers as to the existence of the kept file.
3327 (dired-relist-file kept-file)))))
3329 (defun clearcase-uncheckout-seq (files)
3330 "Uncheckout a sequence of FILES."
3333 (function clearcase-assert-file-ok-to-uncheckout)
3337 (function clearcase-uncheckout)
3344 (defun clearcase-describe (file)
3345 "Give a ClearCase description of FILE."
3347 (clearcase-utl-populate-and-view-buffer
3352 (clearcase-ct-do-cleartool-command "describe" file 'unused)))))
3354 (defun clearcase-describe-seq (files)
3355 "Give a ClearCase description of the sequence of FILES."
3356 (error "Not yet implemented"))
3362 (defun clearcase-commented-mkbrtype (typename &optional comment)
3364 (clearcase-comment-start-entry (format "mkbrtype:%s" typename)
3365 "Enter a comment for the new branch type."
3366 'clearcase-commented-mkbrtype
3368 (clearcase-with-tempfile
3370 (write-region comment nil comment-file nil 'noprint)
3371 (let ((qualified-typename typename))
3372 (if (not (string-match "@" typename))
3373 (setq qualified-typename
3374 (format "%s@%s" typename default-directory)))
3376 (clearcase-ct-cleartool-cmd "mkbrtype"
3378 (clearcase-path-native comment-file)
3379 qualified-typename)))))
3383 ;;{{{ Browse vtree (using Dired Mode)
3385 (defun clearcase-file-ok-to-browse (file)
3387 (or (equal 'version (clearcase-fprop-mtype file))
3388 (equal 'directory-version (clearcase-fprop-mtype file)))
3389 (clearcase-file-is-in-mvfs-p file)))
3391 (defun clearcase-browse-vtree (file &optional graphical)
3392 (if (not (clearcase-fprop-file-is-version-p file))
3393 (error "%s is not a Clearcase element" file))
3396 (clearcase-gui-vtree-browser file)
3399 (if (not (clearcase-file-is-in-mvfs-p file))
3400 (error "File is not in MVFS"))
3402 (let* ((version-path (clearcase-vxpath-cons-vxpath
3404 (or (clearcase-vxpath-version-part file)
3405 (clearcase-fprop-version file))))
3406 ;; nyi: Can't seem to get latest first here.
3408 (dired-listing-switches (concat dired-listing-switches
3411 (branch-path (clearcase-vxpath-branch version-path))
3413 ;; Position cursor to the version we came from.
3414 ;; If it was checked-out, go to predecessor.
3416 (version-number (clearcase-vxpath-version
3417 (if (clearcase-fprop-checked-out file)
3418 (clearcase-fprop-predecessor-version file)
3421 (if (file-exists-p version-path)
3423 ;; Invoke dired on the directory of the version branch.
3427 (clearcase-dired-sort-by-date)
3429 (if (re-search-forward (concat "[ \t]+"
3431 (regexp-quote version-number)
3436 (goto-char (match-beginning 1))))
3437 (dired (concat file clearcase-vxpath-glue))
3439 ;; nyi: We want ANY directory in the history tree to appear with
3440 ;; newest first. Probably requires a hook to dired mode.
3442 (clearcase-dired-sort-by-date)))))
3448 (defun clearcase-list-history (file)
3449 "List the change history of FILE.
3451 FILE can be a file or a directory. If it is a directory, only the information
3452 on the directory element itself is listed, not on its contents."
3454 (let ((mtype (clearcase-fprop-mtype file)))
3455 (if (or (eq mtype 'version)
3456 (eq mtype 'directory-version))
3458 (message "Listing element history...")
3460 (clearcase-utl-populate-and-view-buffer
3465 (clearcase-ct-do-cleartool-command "lshistory"
3468 (if (eq mtype 'directory-version)
3470 (setq default-directory (file-name-directory file))
3471 (while (looking-at "=3D*\n")
3472 (delete-char (- (match-end 0) (match-beginning 0)))
3474 (goto-char (point-min))
3475 (if (looking-at "[\b\t\n\v\f\r ]+")
3476 (delete-char (- (match-end 0) (match-beginning 0)))))))
3477 (message "Listing element history...done"))
3479 (error "%s is not a ClearCase element" file))))
3485 (defun clearcase-files-are-identical (f1 f2)
3486 "Test if FILE1 and FILE2 have identical contents."
3488 (clearcase-when-debugging
3489 (if (not (file-exists-p f1))
3490 (error "%s non-existent" f1))
3491 (if (not (file-exists-p f2))
3492 (error "%s non-existent" f2)))
3494 (zerop (call-process "cleardiff" nil nil nil "-status_only" f1 f2)))
3496 (defun clearcase-diff-files (file1 file2)
3497 "Run cleardiff on FILE1 and FILE2 and display the differences."
3498 (if clearcase-use-normal-diff
3499 (clearcase-do-command 2
3500 clearcase-normal-diff-program
3502 (append clearcase-normal-diff-arguments
3504 (clearcase-do-command 2
3507 (list "-diff_format" file1)))
3508 (let ((diff-size (save-excursion
3509 (set-buffer "*clearcase*")
3511 (if (zerop diff-size)
3512 (message "No differences")
3513 (clearcase-port-view-buffer-other-window "*clearcase*")
3515 (shrink-window-if-larger-than-buffer))))
3521 (defun clearcase-what-rule (file)
3522 (let ((result (clearcase-ct-cleartool-cmd "ls"
3524 (clearcase-path-native file))))
3525 (if (string-match "Rule: \\(.*\\)\n" result)
3526 (message (substring result
3527 ;; Be a little more verbose
3528 (match-beginning 0) (match-end 1)))
3535 ;;{{{ File property cache
3537 ;; ClearCase properties of files are stored in a vector in a hashtable with the
3538 ;; absolute-filename (with no trailing slashes) as the lookup key.
3542 ;; [0] truename : string
3543 ;; [1] mtype : { nil, view-private-object, version,
3544 ;; directory-version, file-element,
3545 ;; dir-element, derived-object
3547 ;; [2] checked-out : boolean
3548 ;; [3] reserved : boolean
3549 ;; [4] version : string
3550 ;; [5] predecessor-version : string
3552 ;; [7] user : string
3553 ;; [8] date : string (yyyymmdd.hhmmss)
3554 ;; [9] time-last-described : (N, N, N) time when the properties were last read
3556 ;; [10] viewtag : string
3557 ;; [11] comment : string
3558 ;; [12] slink-text : string (empty string if not symlink)
3559 ;; [13] hijacked : boolean
3561 ;; nyi: other possible properties to record:
3562 ;; mtime when last described (lets us know when the cached properties
3567 (defun clearcase-fprop-unparse-properties (properties)
3568 "Return a string suitable for printing PROPERTIES."
3570 (format "truename: %s\n" (aref properties 0))
3571 (format "mtype: %s\n" (aref properties 1))
3572 (format "checked-out: %s\n" (aref properties 2))
3573 (format "reserved: %s\n" (aref properties 3))
3574 (format "version: %s\n" (aref properties 4))
3575 (format "predecessor-version: %s\n" (aref properties 5))
3576 (format "oid: %s\n" (aref properties 6))
3577 (format "user: %s\n" (aref properties 7))
3578 (format "date: %s\n" (aref properties 8))
3579 (format "time-last-described: %s\n" (current-time-string (aref properties 9)))
3580 (format "viewtag: %s\n" (aref properties 10))
3581 (format "comment: %s\n" (aref properties 11))
3582 (format "slink-text: %s\n" (aref properties 12))
3583 (format "hijacked: %s\n" (aref properties 13))))
3585 (defun clearcase-fprop-display-properties (file)
3586 "Display the recorded ClearCase properties of FILE."
3588 (let* ((abs-file (expand-file-name file))
3589 (properties (clearcase-fprop-lookup-properties abs-file)))
3591 (let ((unparsed-properties (clearcase-fprop-unparse-properties properties)))
3592 (clearcase-utl-populate-and-view-buffer
3595 (function (lambda ()
3596 (insert unparsed-properties)))))
3597 (error "Properties for %s not stored" file))))
3599 (defun clearcase-fprop-dump-to-current-buffer ()
3600 "Dump to the current buffer the table recording ClearCase properties of files."
3602 (insert (format "File describe count: %s\n" clearcase-fprop-describe-count))
3606 (let ((properties (symbol-value symbol)))
3608 (format "key: %s\n" (symbol-name symbol))
3610 (clearcase-fprop-unparse-properties properties)))))
3611 clearcase-fprop-hashtable)
3614 (defun clearcase-fprop-dump ()
3616 (clearcase-utl-populate-and-view-buffer
3619 (function (lambda ()
3620 (clearcase-fprop-dump-to-current-buffer)))))
3624 (defvar clearcase-fprop-hashtable (make-vector 31 0)
3625 "Obarray for per-file ClearCase properties.")
3627 (defun clearcase-fprop-canonicalise-path (filename)
3628 ;; We want DIR/y and DIR\y to map to the same cache entry on ms-windows.
3629 ;; We want DIR and DIR/ (and on windows DIR\) to map to the same cache entry.
3631 ;; However, on ms-windows avoid canonicalising X:/ to X: because, for some
3632 ;; reason, cleartool+desc fails on X:, but works on X:/
3634 (setq filename (clearcase-path-canonicalise-slashes filename))
3635 (if (and clearcase-on-mswindows
3636 (string-match (concat "^" "[A-Za-z]:" clearcase-pname-sep-regexp "$")
3639 (clearcase-utl-strip-trailing-slashes filename)))
3641 (defun clearcase-fprop-clear-all-properties ()
3642 "Delete all entries in the clearcase-fprop-hashtable."
3643 (setq clearcase-fprop-hashtable (make-vector 31 0)))
3645 (defun clearcase-fprop-store-properties (file properties)
3646 "For FILE, store its ClearCase PROPERTIES in the clearcase-fprop-hashtable."
3647 (assert (file-name-absolute-p file))
3648 (set (intern (clearcase-fprop-canonicalise-path file)
3649 clearcase-fprop-hashtable) properties))
3651 (defun clearcase-fprop-unstore-properties (file)
3652 "For FILE, delete its entry in the clearcase-fprop-hashtable."
3653 (assert (file-name-absolute-p file))
3654 (unintern (clearcase-fprop-canonicalise-path file) clearcase-fprop-hashtable))
3656 (defun clearcase-fprop-lookup-properties (file)
3657 "For FILE, lookup and return its ClearCase properties from the
3658 clearcase-fprop-hashtable."
3659 (assert (file-name-absolute-p file))
3660 (symbol-value (intern-soft (clearcase-fprop-canonicalise-path file)
3661 clearcase-fprop-hashtable)))
3663 (defun clearcase-fprop-get-properties (file)
3664 "For FILE, make sure its ClearCase properties are in the hashtable
3665 and then return them."
3666 (or (clearcase-fprop-lookup-properties file)
3668 (condition-case signal-info
3669 (clearcase-fprop-read-properties file)
3672 (clearcase-trace (format "(clearcase-fprop-read-properties %s) signalled error: %s"
3675 (make-vector 31 nil))))))
3676 (clearcase-fprop-store-properties file properties)
3679 (defun clearcase-fprop-truename (file)
3680 "For FILE, return its \"truename\" ClearCase property."
3681 (aref (clearcase-fprop-get-properties file) 0))
3683 (defun clearcase-fprop-mtype (file)
3684 "For FILE, return its \"mtype\" ClearCase property."
3685 (aref (clearcase-fprop-get-properties file) 1))
3687 (defun clearcase-fprop-checked-out (file)
3688 "For FILE, return its \"checked-out\" ClearCase property."
3689 (aref (clearcase-fprop-get-properties file) 2))
3691 (defun clearcase-fprop-reserved (file)
3692 "For FILE, return its \"reserved\" ClearCase property."
3693 (aref (clearcase-fprop-get-properties file) 3))
3695 (defun clearcase-fprop-version (file)
3696 "For FILE, return its \"version\" ClearCase property."
3697 (aref (clearcase-fprop-get-properties file) 4))
3699 (defun clearcase-fprop-predecessor-version (file)
3700 "For FILE, return its \"predecessor-version\" ClearCase property."
3701 (aref (clearcase-fprop-get-properties file) 5))
3703 (defun clearcase-fprop-oid (file)
3704 "For FILE, return its \"oid\" ClearCase property."
3705 (aref (clearcase-fprop-get-properties file) 6))
3707 (defun clearcase-fprop-user (file)
3708 "For FILE, return its \"user\" ClearCase property."
3709 (aref (clearcase-fprop-get-properties file) 7))
3711 (defun clearcase-fprop-date (file)
3712 "For FILE, return its \"date\" ClearCase property."
3713 (aref (clearcase-fprop-get-properties file) 8))
3715 (defun clearcase-fprop-time-last-described (file)
3716 "For FILE, return its \"time-last-described\" ClearCase property."
3717 (aref (clearcase-fprop-get-properties file) 9))
3719 (defun clearcase-fprop-viewtag (file)
3720 "For FILE, return its \"viewtag\" ClearCase property."
3721 (aref (clearcase-fprop-get-properties file) 10))
3723 (defun clearcase-fprop-comment (file)
3724 "For FILE, return its \"comment\" ClearCase property."
3725 (aref (clearcase-fprop-get-properties file) 11))
3727 (defun clearcase-fprop-vob-slink-text (file)
3728 "For FILE, return its \"slink-text\" ClearCase property."
3729 (aref (clearcase-fprop-get-properties file) 12))
3731 (defun clearcase-fprop-hijacked (file)
3732 "For FILE, return its \"hijacked\" ClearCase property."
3733 (aref (clearcase-fprop-get-properties file) 13))
3735 (defun clearcase-fprop-set-comment (file comment)
3736 "For FILE, set its \"comment\" ClearCase property to COMMENT."
3737 (aset (clearcase-fprop-get-properties file) 11 comment))
3739 (defun clearcase-fprop-owner-of-checkout (file)
3740 "For FILE, return whether the current user has it checked-out."
3741 (if (clearcase-fprop-checked-out file)
3742 (clearcase-fprop-user file)
3745 (defun clearcase-fprop-file-is-vob-slink-p (object-name)
3746 (not (zerop (length (clearcase-fprop-vob-slink-text object-name)))))
3748 (defun clearcase-fprop-file-is-version-p (object-name)
3750 (let ((mtype (clearcase-fprop-mtype object-name)))
3751 (or (eq 'version mtype)
3752 (eq 'directory-version mtype)))))
3754 ;; Read the object's ClearCase properties using cleartool and the Lisp reader.
3756 ;; nyi: for some reason the \n before the %c necessary here so avoid confusing the
3757 ;; cleartool/tq interface. Completely mysterious. Arrived at by
3760 (defvar clearcase-fprop-fmt-string
3762 ;; Yuck. Different forms of quotation are needed here apparently to deal with
3763 ;; all the various ways of spawning sub-process on the the various platforms
3764 ;; (XEmacs vs. GnuEmacs, Win32 vs. Unix, Cygwin-built vs. native-built).
3766 (if clearcase-on-mswindows
3767 (if clearcase-xemacs-p
3770 (if clearcase-on-cygwin
3773 "[nil \\\"%m\\\" \\\"%f\\\" \\\"%Rf\\\" \\\"%Sn\\\" \\\"%PSn\\\" \\\"%On\\\" \\\"%u\\\" \\\"%Nd\\\" nil nil nil \\\"%[slink_text]p\\\" nil ]\\n%c"
3776 "[nil \\\"%m\\\" \\\"%f\\\" \\\"%Rf\\\" \\\"%Sn\\\" \\\"%PSn\\\" \\\"%On\\\" \\\"%u\\\" \\\"%Nd\\\" nil nil nil \\\"%[slink_text]p\\\" nil]\n%c")
3780 "[nil \"%m\" \"%f\" \"%Rf\" \"%Sn\" \"%PSn\" \"%On\" \"%u\" \"%Nd\" nil nil nil \"%[slink_text]p\" nil]\\n%c")
3784 "'[nil \"%m\" \"%f\" \"%Rf\" \"%Sn\" \"%PSn\" \"%On\" \"%u\" \"%Nd\" nil nil nil \"%[slink_text]p\" nil]\\n%c'")
3786 "Format for cleartool+describe command when reading the
3787 ClearCase properties of a file")
3789 (defvar clearcase-fprop-describe-count 0
3790 "Count the number of times clearcase-fprop-read-properties is called")
3792 (defun clearcase-fprop-read-properties (file)
3793 "Invoke the cleartool+describe command to obtain the ClearCase
3794 properties of FILE."
3795 (assert (file-name-absolute-p file))
3796 (let* ((truename (clearcase-fprop-canonicalise-path (file-truename (expand-file-name file)))))
3798 ;; If the object doesn't exist, signal an error
3800 (if (or (not (file-exists-p (clearcase-vxpath-element-part file)))
3801 (not (file-exists-p (clearcase-vxpath-element-part truename))))
3802 (error "File doesn't exist: %s" file)
3804 ;; Run cleartool+ describe and capture the output as a string:
3806 (let ((desc-string (clearcase-ct-cleartool-cmd "desc"
3808 clearcase-fprop-fmt-string
3809 (clearcase-path-native truename))))
3810 (setq clearcase-fprop-describe-count (1+ clearcase-fprop-describe-count))
3812 ;;(clearcase-trace (format "desc of %s <<<<" truename))
3813 ;;(clearcase-trace desc-string)
3814 ;;(clearcase-trace (format "desc of %s >>>>" truename))
3816 ;; Read all but the comment, using the Lisp reader, and then copy
3817 ;; what's left as the comment. We don't try to use the Lisp reader to
3818 ;; fetch the comment to avoid problems with quotation.
3820 ;; nyi: it would be nice if we could make cleartool use "/" as pname-sep,
3821 ;; because read-from-string will barf on imbedded "\". For now
3822 ;; run clearcase-path-canonicalise-slashes over the cleartool
3823 ;; output before invoking the Lisp reader.
3825 (let* ((first-read (read-from-string (clearcase-path-canonicalise-slashes desc-string)))
3826 (result (car first-read))
3827 (bytes-read (cdr first-read))
3828 (comment (substring desc-string (1+ bytes-read)))) ;; skip \n
3830 ;; Plug in the slots I left empty:
3832 (aset result 0 truename)
3833 (aset result 9 (current-time))
3835 (aset result 11 comment)
3837 ;; Convert mtype to an enumeration:
3839 (let ((mtype-string (aref result 1)))
3841 ((string= mtype-string "version")
3842 (aset result 1 'version))
3844 ((string= mtype-string "directory version")
3845 (aset result 1 'directory-version))
3847 ((string= mtype-string "view private object")
3848 (aset result 1 'view-private-object)
3850 ;; If we're in a snapshot see if it is hijacked by running
3851 ;; ct+desc FILE@@. No error indicates it's hijacked.
3853 (if (clearcase-file-would-be-in-snapshot-p truename)
3857 (clearcase-ct-cleartool-cmd
3860 (concat (clearcase-path-native truename)
3861 clearcase-vxpath-glue)))
3864 ((string= mtype-string "file element")
3865 (aset result 1 'file-element))
3867 ((string= mtype-string "directory element")
3868 (aset result 1 'directory-element))
3870 ((string= mtype-string "derived object")
3871 (aset result 1 'derived-object))
3873 ;; For now treat checked-in DOs as versions.
3875 ((string= mtype-string "derived object version")
3876 (aset result 1 'version))
3878 ;; On NT, coerce the mtype of symlinks into that
3879 ;; of their targets.
3881 ;; nyi: I think this is approximately right.
3883 ((and (string= mtype-string "symbolic link")
3884 clearcase-on-mswindows)
3885 (if (file-directory-p truename)
3886 (aset result 1 'directory-version)
3887 (aset result 1 'version)))
3889 ;; We get this on paths like foo.c@@/main
3891 ((string= mtype-string "branch")
3892 (aset result 1 'branch))
3894 ((string= mtype-string "**null meta type**")
3895 (aset result 1 nil))
3898 (error "Unknown mtype returned by cleartool+describe: %s"
3901 ;; nyi: possible efficiency win: only evaluate the viewtag on demand.
3904 (aset result 10 (clearcase-file-viewtag truename)))
3906 ;; Convert checked-out field to boolean:
3908 (aset result 2 (not (zerop (length (aref result 2)))))
3910 ;; Convert reserved field to boolean:
3912 (aset result 3 (string= "reserved" (aref result 3)))
3914 ;; Return the array of properties.
3920 ;;{{{ View property cache
3922 ;; ClearCase properties of views are stored in a vector in a hashtable
3923 ;; with the viewtag as the lookup key.
3927 ;; [0] ucm : boolean
3928 ;; [1] stream : string
3929 ;; [2] pvob : string
3930 ;; [3] activities : list of strings
3931 ;; [4] current-activity : string
3935 (defun clearcase-vprop-dump-to-current-buffer ()
3936 "Dump to the current buffer the table recording ClearCase properties of views."
3937 (insert (format "View describe count: %s\n" clearcase-vprop-describe-count))
3941 (let ((properties (symbol-value symbol)))
3943 (format "viewtag: %s\n" (symbol-name symbol))
3945 (clearcase-vprop-unparse-properties properties)))))
3946 clearcase-vprop-hashtable)
3949 (defun clearcase-vprop-dump ()
3951 (clearcase-utl-populate-and-view-buffer
3954 (function (lambda ()
3955 (clearcase-vprop-dump-to-current-buffer)))))
3957 (defun clearcase-vprop-unparse-properties (properties)
3958 "Return a string suitable for printing PROPERTIES."
3960 (format "ucm: %s\n" (aref properties 0))
3961 (format "stream: %s\n" (aref properties 1))
3962 (format "pvob: %s\n" (aref properties 2))
3963 (format "activities: %s\n" (aref properties 3))
3964 (format "current-activity: %s\n" (aref properties 4))))
3968 ;;{{{ Asynchronously fetching view properties:
3970 (defvar clearcase-vprop-timer nil)
3971 (defvar clearcase-vprop-work-queue nil)
3973 (defun clearcase-vprop-schedule-work (viewtag)
3974 ;; Add to the work queue.
3976 (setq clearcase-vprop-work-queue (cons viewtag
3977 clearcase-vprop-work-queue))
3978 ;; Create the timer if necessary.
3980 (if (null clearcase-vprop-timer)
3981 (if clearcase-xemacs-p
3984 (setq clearcase-vprop-timer
3985 (run-with-idle-timer 5 t 'clearcase-vprop-timer-function))
3989 (setq clearcase-vprop-timer (timer-create))
3990 (timer-set-function clearcase-vprop-timer 'clearcase-vprop-timer-function)
3991 (timer-set-idle-time clearcase-vprop-timer 5)
3992 (timer-activate-when-idle clearcase-vprop-timer)))))
3994 (defun clearcase-vprop-timer-function ()
3995 ;; Process the work queue and empty it.
3997 (mapcar (function (lambda (viewtag)
3999 (clearcase-vprop-get-properties viewtag))))
4000 clearcase-vprop-work-queue)
4001 (setq clearcase-vprop-work-queue nil)
4003 ;; Cancel the timer.
4005 (if clearcase-xemacs-p
4006 (delete-itimer clearcase-vprop-timer)
4007 (cancel-timer clearcase-vprop-timer))
4008 (setq clearcase-vprop-timer nil))
4012 (defvar clearcase-vprop-hashtable (make-vector 31 0)
4013 "Obarray for per-view ClearCase properties.")
4015 (defun clearcase-vprop-clear-all-properties ()
4016 "Delete all entries in the clearcase-vprop-hashtable."
4017 (setq clearcase-vprop-hashtable (make-vector 31 0)))
4019 (defun clearcase-vprop-store-properties (viewtag properties)
4020 "For VIEW, store its ClearCase PROPERTIES in the clearcase-vprop-hashtable."
4021 (set (intern viewtag clearcase-vprop-hashtable) properties))
4023 (defun clearcase-vprop-unstore-properties (viewtag)
4024 "For VIEWTAG, delete its entry in the clearcase-vprop-hashtable."
4025 (unintern viewtag clearcase-vprop-hashtable))
4027 (defun clearcase-vprop-lookup-properties (viewtag)
4028 "For VIEWTAG, lookup and return its ClearCase properties from the
4029 clearcase-vprop-hashtable."
4030 (symbol-value (intern-soft viewtag clearcase-vprop-hashtable)))
4032 (defun clearcase-vprop-get-properties (viewtag)
4033 "For VIEWTAG, make sure it's ClearCase properties are in the hashtable
4034 and then return them."
4035 (or (clearcase-vprop-lookup-properties viewtag)
4036 (let ((properties (clearcase-vprop-read-properties viewtag)))
4037 (clearcase-vprop-store-properties viewtag properties)
4040 (defun clearcase-vprop-ucm (viewtag)
4041 "For VIEWTAG, return its \"ucm\" ClearCase property."
4042 (aref (clearcase-vprop-get-properties viewtag) 0))
4044 (defun clearcase-vprop-stream (viewtag)
4045 "For VIEWTAG, return its \"stream\" ClearCase property."
4046 (aref (clearcase-vprop-get-properties viewtag) 1))
4048 (defun clearcase-vprop-pvob (viewtag)
4049 "For VIEWTAG, return its \"stream\" ClearCase property."
4050 (aref (clearcase-vprop-get-properties viewtag) 2))
4052 (defun clearcase-vprop-activities (viewtag)
4053 "For VIEWTAG, return its \"activities\" ClearCase property."
4055 ;; If the activity set has been flushed, go and schedule a re-fetch.
4057 (let ((properties (clearcase-vprop-get-properties viewtag)))
4058 (if (null (aref properties 3))
4059 (aset properties 3 (clearcase-vprop-read-activities-asynchronously viewtag))))
4061 ;; Now poll, waiting for the activities to be available.
4063 (let ((loop-count 0))
4064 ;; If there is a background process still reading the activities,
4065 ;; wait for it to finish.
4067 ;; nyi: probably want a timeout here.
4069 ;; nyi: There seems to be a race on NT in accept-process-output so that
4070 ;; we would wait forever.
4072 (if (not clearcase-on-mswindows)
4073 ;; Unix synchronization with the end of the process
4074 ;; which is reading activities.
4076 (while (bufferp (aref (clearcase-vprop-get-properties viewtag) 3))
4078 (set-buffer (aref (clearcase-vprop-get-properties viewtag) 3))
4079 (message "Reading activity list...")
4080 (setq loop-count (1+ loop-count))
4081 (accept-process-output clearcase-vprop-async-proc)))
4083 ;; NT synchronization with the end of the process which is reading
4086 ;; Unfortunately on NT we can't rely on the process sentinel being called
4087 ;; so we have to explicitly test the process status.
4089 (while (bufferp (aref (clearcase-vprop-get-properties viewtag) 3))
4090 (message "Reading activity list...")
4092 (set-buffer (aref (clearcase-vprop-get-properties viewtag) 3))
4093 (if (or (not (processp clearcase-vprop-async-proc))
4094 (eq 'exit (process-status clearcase-vprop-async-proc)))
4096 ;; The process has finished or gone away and apparently
4097 ;; the sentinel didn't get called which would have called
4098 ;; clearcase-vprop-finish-reading-activities, so call it
4101 (clearcase-vprop-finish-reading-activities (current-buffer))
4103 ;; The process is apparently still running, so wait
4105 (setq loop-count (1+ loop-count))
4108 (if (not (zerop loop-count))
4109 (message "Reading activity list...done"))
4111 (aref (clearcase-vprop-get-properties viewtag) 3)))
4113 (defun clearcase-vprop-current-activity (viewtag)
4114 "For VIEWTAG, return its \"current-activity\" ClearCase property."
4115 (aref (clearcase-vprop-get-properties viewtag) 4))
4117 (defun clearcase-vprop-set-activities (viewtag activities)
4118 "For VIEWTAG, set its \"activities\" ClearCase property to ACTIVITIES."
4119 (let ((properties (clearcase-vprop-lookup-properties viewtag)))
4120 ;; We must only set the activities for an existing vprop entry.
4123 (aset properties 3 activities)))
4125 (defun clearcase-vprop-flush-activities (viewtag)
4126 "For VIEWTAG, set its \"activities\" ClearCase property to nil,
4127 to cause a future re-fetch."
4128 (clearcase-vprop-set-activities viewtag nil))
4130 (defun clearcase-vprop-set-current-activity (viewtag activity)
4131 "For VIEWTAG, set its \"current-activity\" ClearCase property to ACTIVITY."
4132 (aset (clearcase-vprop-get-properties viewtag) 4 activity))
4134 ;; Read the object's ClearCase properties using cleartool lsview and cleartool lsstream.
4136 (defvar clearcase-vprop-describe-count 0
4137 "Count the number of times clearcase-vprop-read-properties is called")
4139 (defvar clearcase-lsstream-fmt-string
4140 (if clearcase-on-mswindows
4141 (if clearcase-xemacs-p
4144 (if clearcase-on-cygwin
4147 "[\\\"%n\\\" \\\"%[master]p\\\" ]"
4150 "[\\\"%n\\\" \\\"%[master]p\\\" ]")
4153 "[\"%n\" \"%[master]p\" ]")
4156 "'[\"%n\" \"%[master]p\" ]'"))
4158 (defun clearcase-vprop-read-properties (viewtag)
4159 "Invoke cleartool commands to obtain the ClearCase
4160 properties of VIEWTAG."
4162 ;; We used to use "ct+lsview -properties -full TAG", but this seemed to take
4163 ;; a long time in some circumstances. It appears to be because the
4164 ;; ADM_VIEW_GET_INFO RPC can take up to 60 seconds in certain circumstances
4165 ;; (typically on my laptop with self-contained ClearCase region).
4167 ;; Accordingly, since we don't really need to store snapshotness, the minimum
4168 ;; we really need to discover about a view is whether it is UCM-attached. For
4169 ;; this the much faster ct+lsstream suffices.
4171 (let* ((result (make-vector 5 nil)))
4172 (if (not clearcase-v3)
4176 (activity-names nil)
4177 (activity-titles nil)
4179 (current-activity nil)
4182 ;; This was necessary to make sure the "done" message was always
4183 ;; displayed. Not quite sure why.
4187 (message "Reading view properties...")
4188 (setq ret (clearcase-ct-blocking-call "lsstream" "-fmt"
4189 clearcase-lsstream-fmt-string
4192 (setq clearcase-vprop-describe-count (1+ clearcase-vprop-describe-count))
4194 (if (setq ucm (not (zerop (length ret))))
4196 ;; It's apparently a UCM view
4198 (let* ((first-read (read-from-string (clearcase-utl-escape-backslashes ret)))
4199 (array-read (car first-read))
4200 (bytes-read (cdr first-read)))
4204 (setq stream (aref array-read 0))
4206 ;; Get PVOB tag from something like "unix@/vobs/projects"
4208 (let ((s (aref array-read 1)))
4209 (if (string-match "@" s)
4210 (setq pvob (substring s (match-end 0)))
4213 ;; Get the activity list and store as a list of (NAME . TITLE) pairs
4215 (setq activities (clearcase-vprop-read-activities-asynchronously viewtag))
4217 ;; Get the current activity
4219 (let ((name-string (clearcase-ct-blocking-call "lsact" "-cact" "-fmt" "%n"
4221 (if (not (zerop (length name-string)))
4222 (setq current-activity name-string)))
4225 (aset result 1 stream)
4226 (aset result 2 pvob)
4227 (aset result 3 activities)
4228 (aset result 4 current-activity))))
4230 (message "Reading view properties...done"))))
4234 (defvar clearcase-vprop-async-viewtag nil)
4235 (defvar clearcase-vprop-async-proc nil)
4236 (defun clearcase-vprop-read-activities-asynchronously (viewtag)
4237 (let ((buf-name (format "*clearcase-activities-%s*" viewtag)))
4238 ;; Clean up old instance of the buffer we use to fetch activities:
4240 (let ((buf (get-buffer buf-name)))
4245 (if (and (boundp 'clearcase-vprop-async-proc)
4246 clearcase-vprop-async-proc)
4248 (kill-process clearcase-vprop-async-proc)
4250 (kill-buffer buf))))
4252 ;; Create a buffer and an associated new process to read activities in the
4253 ;; background. We return the buffer to be stored in the activities field of
4254 ;; the view-properties record. The function clearcase-vprop-activities will
4255 ;; recognise when the asynch fetching is still underway and wait for it to
4258 ;; The process has a sentinel function which is supposed to get called when
4259 ;; the process finishes. This sometimes doesn't happen on Windows, so that
4260 ;; clearcase-vprop-activities has to do a bit more work. (Perhaps a race
4261 ;; exists: the process completes before the sentinel can be set ?)
4263 (let* ((buf (get-buffer-create buf-name))
4264 (proc (start-process (format "*clearcase-activities-process-%s*" viewtag)
4266 clearcase-cleartool-path
4267 "lsact" "-view" viewtag)))
4268 (process-kill-without-query proc)
4271 ;; Create a sentinel to parse and store the activities when the
4272 ;; process finishes. We record the viewtag as a buffer-local
4273 ;; variable so the sentinel knows where to store the activities.
4275 (set (make-local-variable 'clearcase-vprop-async-viewtag) viewtag)
4276 (set (make-local-variable 'clearcase-vprop-async-proc) proc)
4277 (set-process-sentinel proc 'clearcase-vprop-read-activities-sentinel))
4278 ;; Return the buffer.
4282 (defun clearcase-vprop-read-activities-sentinel (process event-string)
4283 (clearcase-trace "Activity reading process sentinel called")
4284 (if (not (equal "finished\n" event-string))
4287 (error "Reading activities failed: %s" event-string))
4288 (clearcase-vprop-finish-reading-activities (process-buffer process)))
4290 (defun clearcase-vprop-finish-reading-activities (buffer)
4291 (let ((activity-list nil))
4292 (message "Parsing view activities...")
4295 (if (or (not (boundp 'clearcase-vprop-async-viewtag))
4296 (null clearcase-vprop-async-viewtag))
4297 (error "Internal error: clearcase-vprop-async-viewtag not set"))
4299 ;; Check that our buffer is the one currently expected to supply the
4300 ;; activities. (Avoid races.)
4302 (let ((properties (clearcase-vprop-lookup-properties clearcase-vprop-async-viewtag)))
4304 (eq buffer (aref properties 3)))
4307 ;; Parse the buffer, slicing out the 2nd and 4th fields as name and title.
4309 (goto-char (point-min))
4310 (while (re-search-forward "^[^ \t]+[ \t]+\\([^ \t]+\\)[ \t]+[^ \t]+[ \t]+\"+\\(.*\\)\"$" nil t)
4311 (let ((id (buffer-substring (match-beginning 1)
4313 (title (buffer-substring (match-beginning 2)
4315 (setq activity-list (cons (cons id title)
4318 ;; We've got activity-list in the reverse order that
4319 ;; cleartool+lsactivity generated them. I think this is reverse
4320 ;; chronological order, so keep this order since it is more
4321 ;; convenient when setting to an activity.
4323 ;;(setq activity-list (nreverse activity-list))
4325 (clearcase-vprop-set-activities clearcase-vprop-async-viewtag activity-list))
4327 (kill-buffer buffer))))
4328 (message "Parsing view activities...done")))
4330 ;;{{{ old synchronous activity reader
4332 ;; (defun clearcase-vprop-read-activities-synchronously (viewtag)
4333 ;; "Return a list of (activity-name . title) pairs for VIEWTAG"
4334 ;; ;; nyi: ought to use a variant of clearcase-ct-blocking-call that returns a buffer
4335 ;; ;; rather than a string
4337 ;; ;; Performance: takes around 30 seconds to read 1000 activities.
4338 ;; ;; Too slow to invoke willy-nilly on integration streams for example,
4339 ;; ;; which typically can have 1000+ activities.
4341 ;; (let ((ret (clearcase-ct-blocking-call "lsact" "-view" viewtag)))
4342 ;; (let ((buf (get-buffer-create "*clearcase-temp-activities*"))
4343 ;; (activity-list nil))
4348 ;; (goto-char (point-min))
4349 ;; ;; Slice out the 2nd and 4th fields as name and title
4351 ;; (while (re-search-forward "^[^ \t]+[ \t]+\\([^ \t]+\\)[ \t]+[^ \t]+[ \t]+\"+\\(.*\\)\"$" nil t)
4352 ;; (setq activity-list (cons (cons (buffer-substring (match-beginning 1)
4354 ;; (buffer-substring (match-beginning 2)
4357 ;; (kill-buffer buf))
4359 ;; ;; We've got activity-list in the reverse order that
4360 ;; ;; cleartool+lsactivity generated them. I think this is reverse
4361 ;; ;; chronological order, so keep this order since it is more
4362 ;; ;; convenient when setting to an activity.
4364 ;; ;;(nreverse activity-list))))
4371 ;;{{{ Determining if a checkout was modified.
4373 ;; How to tell if a file changed since checkout ?
4375 ;; In the worst case we actually run "ct diff -pred" but we attempt several
4376 ;; less expensive tests first.
4378 ;; 1. If it's size differs from pred.
4379 ;; 2. The mtime and the ctime are no longer the same.
4381 ;; nyi: Other cheaper tests we could use:
4383 ;; (a) After each Emacs-driven checkout go and immediately fetch the mtime of
4384 ;; the file and store as fprop-checkout-mtime. Then use that to compare
4385 ;; against current mtime. This at least would make this function work
4386 ;; right on files checked out by the current Emacs process.
4388 ;; (b) In the MVFS, after each Emacs-driven checkout go and immediately fetch
4389 ;; the OID and store as fprop-checkout-oid. Then use that to compare
4390 ;; against the current oid (the MVFS assigns a new OID at each write).
4391 ;; This might not always be a win since we'd still need to run cleartool
4392 ;; to get the current OID.
4394 (defun clearcase-file-appears-modified-since-checkout-p (file)
4395 "Return whether FILE appears to have been modified since checkout.
4396 It doesn't examine the file contents."
4398 (if (not (clearcase-fprop-checked-out file))
4401 (let ((mvfs (clearcase-file-is-in-mvfs-p file)))
4403 ;; We consider various cases in order of increasing cost to compute.
4406 ;; Case 1: (MVFS only) the size is different to its predecessor.
4411 (clearcase-utl-file-size file)
4412 ;; nyi: For the snapshot case it'd be nice to get the size of the
4413 ;; predecessor by using "ct+desc -pred -fmt" but there doesn't
4414 ;; seem to be a format descriptor for file size. On the other hand
4415 ;; ct+dump can obtain the size.
4417 (clearcase-utl-file-size (clearcase-vxpath-cons-vxpath
4419 (clearcase-fprop-predecessor-version
4425 ;; Case 2: (MVFS only) the mtime and the ctime are no longer the same.
4427 ;; nyi: At least on Windows there seems to be a small number of seconds
4428 ;; difference here even when the file is not modified.
4429 ;; So we really check to see of they are close.
4431 ;; nyi: This doesn't work in a snapshot view.
4434 (not (clearcase-utl-filetimes-close (clearcase-utl-file-mtime file)
4435 (clearcase-utl-file-ctime file)
4439 'ctime-mtime-not-close))
4442 ;; Case 3: last resort. Actually run a diff against predecessor.
4444 (let ((ret (clearcase-ct-blocking-call "diff"
4449 (if (not (zerop (length ret)))
4460 ;;{{{ Tests for view-residency
4462 ;;{{{ Tests for MVFS file residency
4464 ;; nyi: probably superseded by clearcase-file-would-be-in-view-p
4465 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4467 ;; nyi: this should get at least partially invalidated when
4468 ;; VOBs are unmounted.
4470 ;; nyi: make this different for NT
4472 (defvar clearcase-always-mvfs-regexp (if (not clearcase-on-mswindows)
4475 ;; nyi: express this using drive variable
4479 clearcase-pname-sep-regexp)))
4481 ;; This prevents the clearcase-file-vob-root function from pausing for long periods
4482 ;; stat-ing /net/host@@
4484 ;; nyi: is there something equivalent on NT I need to avoid ?
4487 (defvar clearcase-never-mvfs-regexps (if clearcase-on-mswindows
4491 "^/tmp_mnt/net/[^/]+/"
4493 "Regexps matching those paths we can assume are never inside the MVFS.")
4495 (defvar clearcase-known-vob-root-cache nil)
4497 (defun clearcase-file-would-be-in-mvfs-p (filename)
4498 "Return whether FILE, after it is created, would reside in an MVFS filesystem."
4499 (let ((truename (file-truename filename)))
4500 (if (file-exists-p truename)
4501 (clearcase-file-is-in-mvfs-p truename)
4502 (let ((containing-dir (file-name-as-directory (file-name-directory truename))))
4503 (clearcase-file-is-in-mvfs-p containing-dir)))))
4505 (defun clearcase-file-is-in-mvfs-p (filename)
4506 "Return whether existing FILE, resides in an MVFS filesystem."
4507 (let ((truename (file-truename filename)))
4510 ;; case 1: its prefix matches an "always VOB" prefix like /vobs/...
4512 ;; nyi: problem here: we return true for "/vobs/nonexistent/"
4514 (numberp (string-match clearcase-always-mvfs-regexp truename))
4516 ;; case 2: it has a prefix which is a known VOB-root
4518 (clearcase-file-matches-vob-root truename clearcase-known-vob-root-cache)
4520 ;; case 3: it has an ancestor dir which is a newly met VOB-root
4522 (clearcase-file-vob-root truename))))
4524 (defun clearcase-wd-is-in-mvfs ()
4525 "Return whether the current directory resides in an MVFS filesystem."
4526 (clearcase-file-is-in-mvfs-p (file-truename ".")))
4528 (defun clearcase-file-matches-vob-root (truename vob-root-list)
4529 "Return whether TRUENAME has a prefix in VOB-ROOT-LIST."
4530 (if (null vob-root-list)
4532 (or (numberp (string-match (regexp-quote (car vob-root-list))
4534 (clearcase-file-matches-vob-root truename (cdr vob-root-list)))))
4536 (defun clearcase-file-vob-root (truename)
4537 "File the highest versioned directory in TRUENAME."
4539 ;; Use known non-MVFS patterns to rule some paths out.
4541 (if (apply (function clearcase-utl-or-func)
4542 (mapcar (function (lambda (regexp)
4543 (string-match regexp truename)))
4544 clearcase-never-mvfs-regexps))
4546 (let ((previous-dir nil)
4547 (dir (file-name-as-directory (file-name-directory truename)))
4548 (highest-versioned-directory nil))
4550 (while (not (string-equal dir previous-dir))
4551 (if (clearcase-file-covers-element-p dir)
4552 (setq highest-versioned-directory dir))
4553 (setq previous-dir dir)
4554 (setq dir (file-name-directory (directory-file-name dir))))
4556 (if highest-versioned-directory
4557 (add-to-list 'clearcase-known-vob-root-cache highest-versioned-directory))
4559 highest-versioned-directory)))
4561 ;; Note: you should probably be using clearcase-fprop-mtype instead of this
4562 ;; unless you really know what you're doing (nyi: check usages of this.)
4564 (defun clearcase-file-covers-element-p (path)
4565 "Determine quickly if PATH refers to a Clearcase element,
4566 without caching the result."
4568 ;; nyi: Even faster: consult the fprop cache first ?
4570 (let ((element-dir (concat (clearcase-vxpath-element-part path) clearcase-vxpath-glue)))
4571 (and (file-exists-p path)
4572 (file-directory-p element-dir))))
4576 ;;{{{ Tests for snapshot view residency
4578 ;; nyi: probably superseded by clearcase-file-would-be-in-view-p
4579 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4581 (defvar clearcase-known-snapshot-root-cache nil)
4583 (defun clearcase-file-would-be-in-snapshot-p (filename)
4584 "Return whether FILE, after it is created, would reside in a snapshot view.
4585 If so, return the viewtag."
4586 (let ((truename (file-truename filename)))
4587 (if (file-exists-p truename)
4588 (clearcase-file-is-in-snapshot-p truename)
4589 (let ((containing-dir (file-name-as-directory (file-name-directory truename))))
4590 (clearcase-file-is-in-snapshot-p containing-dir)))))
4592 (defun clearcase-file-is-in-snapshot-p (truename)
4593 "Return whether existing FILE, resides in a snapshot view.
4594 If so, return the viewtag."
4597 ;; case 1: it has a prefix which is a known snapshot-root
4599 (clearcase-file-matches-snapshot-root truename clearcase-known-snapshot-root-cache)
4601 ;; case 2: it has an ancestor dir which is a newly met VOB-root
4603 (clearcase-file-snapshot-root truename)))
4605 (defun clearcase-wd-is-in-snapshot ()
4606 "Return whether the current directory resides in a snapshot view."
4607 (clearcase-file-is-in-snapshot-p (file-truename ".")))
4609 (defun clearcase-file-matches-snapshot-root (truename snapshot-root-list)
4610 "Return whether TRUENAME has a prefix in SNAPSHOT-ROOT-LIST."
4611 (if (null snapshot-root-list)
4613 (or (numberp (string-match (regexp-quote (car snapshot-root-list))
4615 (clearcase-file-matches-snapshot-root truename (cdr snapshot-root-list)))))
4617 ;; This prevents the clearcase-file-snapshot-root function from pausing for long periods
4618 ;; stat-ing /net/host@@
4620 ;; nyi: is there something equivalent on NT I need to avoid ?
4623 (defvar clearcase-never-snapshot-regexps (if clearcase-on-mswindows
4627 "^/tmp_mnt/net/[^/]+/"
4629 "Regexps matching those paths we can assume are never inside a snapshot view.")
4631 (defun clearcase-file-snapshot-root (truename)
4632 "File the the snapshot view root containing TRUENAME."
4634 ;; Use known non-snapshot patterns to rule some paths out.
4636 (if (apply (function clearcase-utl-or-func)
4637 (mapcar (function (lambda (regexp)
4638 (string-match regexp truename)))
4639 clearcase-never-snapshot-regexps))
4641 (let ((previous-dir nil)
4642 (dir (file-name-as-directory (file-name-directory truename)))
4647 (while (and (not (string-equal dir previous-dir))
4650 ;; See if .view.dat exists and contains a valid view uuid
4652 (let ((view-dat-name (concat dir (if clearcase-on-mswindows
4653 "view.dat" ".view.dat"))))
4654 (if (file-readable-p view-dat-name)
4655 (let ((uuid (clearcase-viewdat-to-uuid view-dat-name)))
4658 (setq viewtag (clearcase-view-uuid-to-tag uuid))
4660 (setq viewroot dir)))))))
4662 (setq previous-dir dir)
4663 (setq dir (file-name-directory (directory-file-name dir))))
4666 (add-to-list 'clearcase-known-snapshot-root-cache viewroot))
4668 ;; nyi: update a viewtag==>viewroot map ?
4672 (defun clearcase-viewdat-to-uuid (file)
4673 "Extract the view-uuid from a .view.dat file."
4674 ;; nyi, but return non-nil so clearcase-file-snapshot-root works
4678 (defun clearcase-view-uuid-to-tag (uuid)
4679 "Look up the view-uuid in the register to discover its tag."
4680 ;; nyi, but return non-nil so clearcase-file-snapshot-root works
4686 ;; This is simple-minded but seems to work because cleartool+describe
4687 ;; groks snapshot views.
4689 ;; nyi: Might be wise to cache view-roots to speed this up because the
4690 ;; filename-handlers call this.
4692 ;; nyi: Some possible shortcuts
4693 ;; 1. viewroot-relative path [syntax]
4694 ;; 2. under m:/ on NT [syntax]
4695 ;; 3. setviewed on Unix [find a containing VOB-root]
4696 ;; 4. subst-ed view on NT (calling net use seems very slow though)
4697 ;; [find a containing VOB-root]
4700 (defun clearcase-file-would-be-in-view-p (filename)
4701 "Return whether FILE, after it is created, would reside in a ClearCase view."
4702 (let ((truename (file-truename (expand-file-name filename))))
4704 ;; We use clearcase-path-file-really-exists-p here to make sure we are dealing
4705 ;; with a real file and not something faked by Emacs' file name handlers
4708 (if (clearcase-path-file-really-exists-p truename)
4709 (clearcase-file-is-in-view-p truename)
4710 (let ((containing-dir (file-name-as-directory (file-name-directory truename))))
4711 (and (clearcase-path-file-really-exists-p containing-dir)
4712 (clearcase-file-is-in-view-p containing-dir))))))
4714 (defun clearcase-file-is-in-view-p (filename)
4715 (let ((truename (file-truename (expand-file-name filename))))
4716 ;; Shortcut if the file is a version-extended path.
4718 (or (clearcase-file-snapshot-root truename)
4719 (clearcase-vxpath-p truename)
4720 (clearcase-fprop-mtype truename)
4722 ;; nyi: How to efficiently know if we're in a dynamic-view root
4723 ;; 1. Test each contained name for elementness.
4725 ;; 2. If it is viewroot-relative.
4726 ;; Okay but not sufficient.
4727 ;; How about case v:/ when view is substed ?
4728 ;; 3. We're setviewed.
4729 ;; Okay but not sufficient.
4730 ;; Maintain a cache of viewroots ?
4733 (defun clearcase-file-viewtag (filename)
4734 "Find the viewtag associated with existing FILENAME."
4736 (clearcase-when-debugging
4737 (assert (file-exists-p filename)))
4739 (let ((truename (file-truename (expand-file-name filename))))
4742 ;; Case 1: viewroot-relative path
4745 ((clearcase-vrpath-p truename)
4746 (clearcase-vrpath-viewtag truename))
4748 ;; Case 2: under m:/ on NT
4751 ((and clearcase-on-mswindows
4752 (string-match (concat clearcase-viewroot-drive
4753 clearcase-pname-sep-regexp
4755 clearcase-non-pname-sep-regexp "*"
4759 (substring truename (match-beginning 1) (match-end 1)))
4761 ;; Case 3: setviewed on Unix
4762 ;; ==> read EV, but need to check it's beneath a VOB-root
4764 ((and clearcase-setview-viewtag
4765 (clearcase-file-would-be-in-mvfs-p truename))
4766 clearcase-setview-viewtag)
4768 ;; Case 4: subst-ed view on NT
4769 ;; ==> use ct+pwv -wdview
4770 ;; Case 5: snapshot view
4771 ;; ==> use ct+pwv -wdview
4773 (clearcase-file-wdview truename)))))
4775 (defun clearcase-file-wdview (truename)
4776 "Return the working-directory view associated with TRUENAME,
4778 (let ((default-directory (if (file-directory-p truename)
4780 (file-name-directory truename))))
4781 (clearcase-ct-cd default-directory)
4782 (let ((ret (clearcase-ct-blocking-call "pwv" "-wdview" "-short")))
4783 (if (not (string-match " NONE " ret))
4784 (clearcase-utl-1st-line-of-string ret)))))
4788 ;;{{{ The cleartool sub-process
4790 ;; We use pipes rather than pty's for two reasons:
4792 ;; 1. NT only has pipes
4793 ;; 2. On Solaris there appeared to be a problem in the pty handling part
4794 ;; of Emacs, which resulted in Emacs/tq seeing too many cleartool prompt
4795 ;; strings. This would occasionally occur and prevent the tq-managed
4796 ;; interactions with the cleartool sub-process from working correctly.
4798 ;; Now we use pipes. Cleartool detects the "non-tty" nature of the output
4799 ;; device and doesn't send a prompt. We manufacture an end-of-transaction
4800 ;; marker by sending a "pwd -h" after each cleartool sub-command and then use
4801 ;; the expected output of "Usage: pwd\n" as our end-of-txn pattern for tq.
4803 ;; Even using pipes, the semi-permanent outboard-process using tq doesn't work
4804 ;; well on NT. There appear to be bugs in accept-process-output such that:
4805 ;; 0. there apparently were hairy race conditions, which a sprinkling
4806 ;; of (accept-process-output nil 1) seemed to avoid somewhat.
4807 ;; 1. it never seems to timeout if you name a process as arg1.
4808 ;; 2. it always seems to wait for TIMEOUT, even if there is output ready.
4809 ;; The result seemed to be less responsive tha just calling a fresh cleartool
4810 ;; process for each invocation of clearcase-ct-blocking-call
4812 ;; It still seems worthwhile to make it work on NT, as clearcase-ct-blocking-call
4813 ;; typically takes about 0.5 secs on NT versus 0.05 sec on Solaris,
4814 ;; an order of magnitude difference.
4817 (defconst clearcase-ct-eotxn-cmd "pwd -h\n")
4818 (defconst clearcase-ct-eotxn-response "Usage: pwd\n")
4819 (defconst clearcase-ct-eotxn-response-length (length clearcase-ct-eotxn-response))
4821 (defconst clearcase-ct-subproc-timeout 30
4822 "Timeout on calls to subprocess")
4824 (defvar clearcase-ct-tq nil
4825 "Transaction queue to talk to ClearTool in a subprocess")
4827 (defvar clearcase-ct-return nil
4828 "Return value when we're involved in a blocking call")
4830 (defvar clearcase-ct-view ""
4831 "Current view of cleartool subprocess, or the empty string if none")
4833 (defvar clearcase-ct-wdir ""
4834 "Current working directory of cleartool subprocess,
4835 or the empty string if none")
4837 (defvar clearcase-ct-running nil)
4839 (defun clearcase-ct-accept-process-output (proc timeout)
4840 (accept-process-output proc timeout))
4842 (defun clearcase-ct-start-cleartool ()
4844 (clearcase-trace "clearcase-ct-start-cleartool()")
4845 (let ((process-environment (append '("ATRIA_NO_BOLD=1"
4846 "ATRIA_FORCE_GUI=1")
4847 ;;; emacs is a GUI, right? :-)
4848 process-environment)))
4849 (clearcase-trace (format "Starting cleartool in %s" default-directory))
4850 (let* ( ;; Force the use of a pipe
4852 (process-connection-type nil)
4854 (start-process "cleartool" ;; Absolute path won't work here
4856 clearcase-cleartool-path)))
4857 (process-kill-without-query cleartool-process)
4858 (setq clearcase-ct-view "")
4859 (setq clearcase-ct-tq (tq-create cleartool-process))
4860 (tq-enqueue clearcase-ct-tq
4861 clearcase-ct-eotxn-cmd ;; question
4862 clearcase-ct-eotxn-response ;; regexp
4863 'clearcase-ct-running ;; closure
4865 (while (not clearcase-ct-running)
4866 (message "waiting for cleartool to start...")
4867 (clearcase-ct-accept-process-output (tq-process clearcase-ct-tq)
4868 clearcase-ct-subproc-timeout))
4869 ;; Assign a sentinel to restart it if it dies.
4870 ;; nyi: This needs debugging.
4871 ;;(set-process-sentinel cleartool-process 'clearcase-ct-sentinel)
4873 (clearcase-trace "clearcase-ct-start-cleartool() done")
4874 (message "waiting for cleartool to start...done"))))
4876 ;; nyi: needs debugging.
4878 (defun clearcase-ct-sentinel (process event-string)
4879 (clearcase-trace (format "Cleartool process sentinel called: %s" event-string))
4880 (if (not (eq 'run (process-status process)))
4882 ;; Restart the dead cleartool.
4884 (clearcase-trace "Cleartool process restarted")
4885 (clearcase-ct-start-cleartool))))
4887 (defun clearcase-ct-kill-cleartool ()
4888 "Kill off cleartool subprocess. If another one is needed,
4889 it will be restarted. This may be useful if you're debugging clearcase."
4891 (clearcase-ct-kill-tq))
4893 (defun clearcase-ct-callback (arg val)
4894 (clearcase-trace (format "clearcase-ct-callback:<\n"))
4895 (clearcase-trace val)
4896 (clearcase-trace (format "clearcase-ct-callback:>\n"))
4897 ;; This can only get called when the last thing received from
4898 ;; the cleartool sub-process was clearcase-ct-eotxn-response,
4899 ;; so it is safe to just remove it here.
4901 (setq clearcase-ct-return (substring val 0 (- clearcase-ct-eotxn-response-length))))
4903 (defun clearcase-ct-do-cleartool-command (command file comment &optional extra-args)
4904 "Execute a cleartool command, notifying user and checking for
4905 errors. Output from COMMAND goes to buffer *clearcase*. The last argument of the
4906 command is the name of FILE; this is appended to an optional list of
4910 (setq file (expand-file-name file)))
4912 (error "command must not be a list"))
4913 (if clearcase-command-messages
4915 (message "Running %s on %s..." command file)
4916 (message "Running %s..." command)))
4917 (let ((camefrom (current-buffer))
4920 (set-buffer (get-buffer-create "*clearcase*"))
4921 (setq buffer-read-only nil)
4923 (set (make-local-variable 'clearcase-parent-buffer) camefrom)
4924 (set (make-local-variable 'clearcase-parent-buffer-name)
4925 (concat " from " (buffer-name camefrom)))
4927 ;; This is so that command arguments typed in the *clearcase* buffer will
4928 ;; have reasonable defaults.
4931 (setq default-directory (file-name-directory file)))
4934 (function (lambda (s)
4936 (not (zerop (length s)))
4938 (append squeezed (list s))))))
4941 (clearcase-with-tempfile
4943 (if (not (eq comment 'unused))
4946 (write-region comment nil comment-file nil 'noprint)
4947 (setq squeezed (append squeezed (list "-cfile" (clearcase-path-native comment-file)))))
4948 (setq squeezed (append squeezed (list "-nc")))))
4950 (setq squeezed (append squeezed (list (clearcase-path-native file)))))
4951 (let ((default-directory (file-name-directory
4952 (or file default-directory))))
4953 (clearcase-ct-cd default-directory)
4954 (if clearcase-command-messages
4955 (message "Running %s..." command))
4957 (apply 'clearcase-ct-cleartool-cmd (append (list command) squeezed)))
4958 (if clearcase-command-messages
4959 (message "Running %s...done" command))))
4961 (goto-char (point-min))
4962 (clearcase-view-mode 0 camefrom)
4963 (set-buffer-modified-p nil) ; XEmacs - fsf uses `not-modified'
4964 (if (re-search-forward "^cleartool: Error:.*$" nil t)
4966 (setq status (buffer-substring (match-beginning 0) (match-end 0)))
4967 (clearcase-port-view-buffer-other-window "*clearcase*")
4968 (shrink-window-if-larger-than-buffer)
4969 (error "Running %s...FAILED (%s)" command status))
4970 (if clearcase-command-messages
4971 (message "Running %s...OK" command)))
4972 (set-buffer camefrom)
4975 (defun clearcase-ct-cd (dir)
4977 (string= dir clearcase-ct-wdir))
4979 (clearcase-ct-blocking-call "cd" (clearcase-path-native dir))
4980 (setq clearcase-ct-wdir dir)))
4982 (defun clearcase-ct-cleartool-cmd (&rest cmd)
4983 (apply 'clearcase-ct-blocking-call cmd))
4985 ;; NT Emacs - needs a replacement for tq.
4987 (defun clearcase-ct-get-command-stdout (program &rest args)
4989 Returns PROGRAM's stdout.
4990 ARGS is the command line arguments to PROGRAM."
4991 (let ((buf (get-buffer-create "cleartoolexecution")))
4995 (apply 'call-process program nil buf nil args)
4997 (kill-buffer buf))))
4999 ;; The TQ interaction still doesn't work on NT.
5001 (defvar clearcase-disable-tq clearcase-on-mswindows
5002 "Set to T if the Emacs/cleartool interactions via tq are not working right.")
5004 (defun clearcase-ct-blocking-call (&rest cmd)
5005 (clearcase-trace (format "clearcase-ct-blocking-call(%s)" cmd))
5007 (setq clearcase-ct-return nil)
5009 (if clearcase-disable-tq
5012 (setq clearcase-ct-return (apply 'clearcase-ct-get-command-stdout
5013 clearcase-cleartool-path cmd))
5017 (setq clearcase-ct-return nil)
5018 (if (not clearcase-ct-tq)
5019 (clearcase-ct-start-cleartool))
5025 ;; If the token has imbedded spaces and is not already quoted,
5026 ;; add double quotes.
5028 (setq command (concat command
5030 (clearcase-utl-quote-if-nec token)))))
5032 (tq-enqueue clearcase-ct-tq
5033 (concat command "\n"
5034 clearcase-ct-eotxn-cmd) ;; question
5035 clearcase-ct-eotxn-response ;; regexp
5037 'clearcase-ct-callback) ;; function
5038 (while (not clearcase-ct-return)
5039 (clearcase-ct-accept-process-output (tq-process clearcase-ct-tq)
5040 clearcase-ct-subproc-timeout)))
5043 (while (tq-queue clearcase-ct-tq)
5044 (tq-queue-pop clearcase-ct-tq)))))
5045 (if (string-match "cleartool: Error:" clearcase-ct-return)
5046 (error "cleartool process error %s: "
5047 (substring clearcase-ct-return (match-end 0))))
5048 (clearcase-trace (format "command-result(%s)" clearcase-ct-return))
5049 clearcase-ct-return)
5051 (defun clearcase-ct-kill-tq ()
5052 (setq clearcase-ct-running nil)
5053 (setq clearcase-ct-tq nil)
5054 (process-send-eof (tq-process clearcase-ct-tq))
5055 (kill-process (tq-process clearcase-ct-tq)))
5057 (defun clearcase-ct-kill-buffer-hook ()
5059 ;; NT Emacs - doesn't use tq.
5061 (if (not clearcase-on-mswindows)
5062 (let ((kill-buffer-hook nil))
5063 (if (and (boundp 'clearcase-ct-tq)
5065 (eq (current-buffer) (tq-buffer clearcase-ct-tq)))
5066 (error "Don't kill TQ buffer %s, use `clearcase-ct-kill-tq'" (current-buffer))))))
5068 (add-hook 'kill-buffer-hook 'clearcase-ct-kill-buffer-hook)
5072 ;;{{{ Invoking a command
5074 ;; nyi Would be redundant if we didn't need it to invoke normal-diff-program
5076 (defun clearcase-do-command (okstatus command file &optional extra-args)
5077 "Execute a version-control command, notifying user and checking for errors.
5078 The command is successful if its exit status does not exceed OKSTATUS.
5079 Output from COMMAND goes to buffer *clearcase*. The last argument of the command is
5080 an optional list of EXTRA-ARGS."
5081 (setq file (expand-file-name file))
5082 (if clearcase-command-messages
5083 (message "Running %s on %s..." command file))
5084 (let ((camefrom (current-buffer))
5088 (set-buffer (get-buffer-create "*clearcase*"))
5089 (setq buffer-read-only nil)
5091 (set (make-local-variable 'clearcase-parent-buffer) camefrom)
5092 (set (make-local-variable 'clearcase-parent-buffer-name)
5093 (concat " from " (buffer-name camefrom)))
5094 ;; This is so that command arguments typed in the *clearcase* buffer will
5095 ;; have reasonable defaults.
5097 (setq default-directory (file-name-directory file)
5098 file (file-name-nondirectory file))
5101 (function (lambda (s)
5103 (not (zerop (length s)))
5105 (append squeezed (list s))))))
5107 (setq squeezed (append squeezed (list file)))
5108 (setq status (apply 'call-process command nil t nil squeezed))
5109 (goto-char (point-min))
5110 (clearcase-view-mode 0 camefrom)
5111 (set-buffer-modified-p nil) ; XEmacs - fsf uses `not-modified'
5112 (if (or (not (integerp status)) (< okstatus status))
5114 (clearcase-port-view-buffer-other-window "*clearcase*")
5115 (shrink-window-if-larger-than-buffer)
5116 (error "Running %s...FAILED (%s)" command
5117 (if (integerp status)
5118 (format "status %d" status)
5120 (if clearcase-command-messages
5121 (message "Running %s...OK" command)))
5122 (set-buffer camefrom)
5127 ;;{{{ Viewtag management
5131 (defun clearcase-viewtag-try-to-start-view (viewtag)
5132 "If VIEW is not apparently already visible under viewroot, start it."
5133 (if (not (member viewtag (clearcase-viewtag-started-viewtags)))
5134 (clearcase-viewtag-start-view viewtag)))
5136 (defun clearcase-viewtag-started-viewtags-alist ()
5137 "Return an alist of views that are currently visible under the viewroot."
5141 (list (concat tag "/"))))
5142 (clearcase-viewtag-started-viewtags)))
5144 (defun clearcase-viewtag-started-viewtags ()
5145 "Return the list of viewtags already visible under the viewroot."
5146 (let ((raw-list (if clearcase-on-mswindows
5147 (directory-files clearcase-viewroot-drive)
5148 (directory-files clearcase-viewroot))))
5149 (clearcase-utl-list-filter
5150 (function (lambda (string)
5151 ;; Exclude the ones that start with ".",
5152 ;; and the ones that end with "@@".
5154 (and (not (equal ?. (aref string 0)))
5155 (not (string-match "@@$" string)))))
5158 ;; nyi: Makes sense on NT ?
5159 ;; Probably also want to run subst ?
5160 ;; Need a better high-level interface to start-view
5162 (defun clearcase-viewtag-start-view (viewtag)
5163 "If VIEWTAG is in our cache of valid view names, start it."
5164 (if (clearcase-viewtag-exists viewtag)
5166 (message "Starting view server for %s..." viewtag)
5167 (clearcase-ct-blocking-call "startview" viewtag)
5168 (message "Starting view server for %s...done" viewtag))))
5176 (defvar clearcase-viewtag-cache nil
5177 "Oblist of all known viewtags.")
5179 (defvar clearcase-viewtag-dir-cache nil
5180 "Oblist of all known viewtag dirs.")
5182 (defvar clearcase-viewtag-cache-timeout 1800
5183 "*Default timeout of all-viewtag cache, in seconds.")
5185 (defun clearcase-viewtag-schedule-cache-invalidation ()
5186 "Schedule the next invalidation of clearcase-viewtag-cache."
5187 (run-at-time (format "%s sec" clearcase-viewtag-cache-timeout)
5189 (function (lambda (&rest ignore)
5190 (setq clearcase-viewtag-cache nil)))
5207 (defun clearcase-viewtag-read-all-viewtags ()
5208 "Invoke ct+lsview to get all viewtags, and return an obarry containing them."
5209 (message "Fetching view names...")
5210 (let* ((default-directory "/")
5211 (result (make-vector 1021 0))
5212 (raw-views-string (clearcase-ct-blocking-call "lsview" "-short"))
5213 (view-list (clearcase-utl-split-string-at-char raw-views-string ?\n)))
5214 (message "Fetching view names...done")
5215 (mapcar (function (lambda (string)
5216 (set (intern string result) t)))
5220 (defun clearcase-viewtag-populate-caches ()
5221 (setq clearcase-viewtag-cache (clearcase-viewtag-read-all-viewtags))
5222 (let ((dir-cache (make-vector 1021 0)))
5224 (function (lambda (sym)
5225 (set (intern (concat (symbol-name sym) "/") dir-cache) t)))
5226 clearcase-viewtag-cache)
5227 (setq clearcase-viewtag-dir-cache dir-cache))
5228 (clearcase-viewtag-schedule-cache-invalidation))
5230 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
5234 ;; Exported interfaces
5236 ;; This is for completion of viewtags.
5238 (defun clearcase-viewtag-all-viewtags-obarray ()
5239 "Return an obarray of all valid viewtags as of the last time we looke d."
5240 (if (null clearcase-viewtag-cache)
5241 (clearcase-viewtag-populate-caches))
5242 clearcase-viewtag-cache)
5244 ;; This is for completion of viewtag dirs, like /view/my_view_name/
5245 ;; The trailing slash is required for compatibility with other instances
5246 ;; of filename completion in Emacs.
5248 (defun clearcase-viewtag-all-viewtag-dirs-obarray ()
5249 "Return an obarray of all valid viewtag directory names as of the last time we looked."
5250 (if (null clearcase-viewtag-dir-cache)
5251 (clearcase-viewtag-populate-caches))
5252 clearcase-viewtag-dir-cache)
5254 (defun clearcase-viewtag-exists (viewtag)
5255 (symbol-value (intern-soft viewtag (clearcase-viewtag-all-viewtags-obarray))))
5263 ;;{{{ Pathnames: version-extended
5265 (defun clearcase-vxpath-p (path)
5266 (or (string-match (concat clearcase-vxpath-glue "/") path)
5267 (string-match (concat clearcase-vxpath-glue "\\\\") path)))
5269 (defun clearcase-vxpath-element-part (vxpath)
5270 "Return the element part of version-extended PATH."
5271 (if (string-match clearcase-vxpath-glue vxpath)
5272 (substring vxpath 0 (match-beginning 0))
5275 (defun clearcase-vxpath-version-part (vxpath)
5276 "Return the version part of version-extended PATH."
5277 (if (string-match clearcase-vxpath-glue vxpath)
5278 (substring vxpath (match-end 0))
5281 (defun clearcase-vxpath-branch (vxpath)
5282 "Return the branch part of a version-extended path or of a version"
5283 (if (clearcase-vxpath-p vxpath)
5284 (clearcase-vxpath-cons-vxpath
5285 (clearcase-vxpath-element-part vxpath)
5286 (file-name-directory (clearcase-vxpath-version-part vxpath)))
5287 (file-name-directory vxpath)))
5289 (defun clearcase-vxpath-version (vxpath)
5290 "Return the numeric version part of a version-extended path or of a version"
5291 (if (clearcase-vxpath-p vxpath)
5292 (file-name-nondirectory (clearcase-vxpath-version-part vxpath))
5293 (file-name-nondirectory vxpath)))
5295 (defun clearcase-vxpath-cons-vxpath (file version &optional viewtag)
5296 "Make a ClearCase version-extended pathname for ELEMENT's version VERSION.
5297 If ELEMENT is actually a version-extended pathname, substitute VERSION for
5298 the version included in ELEMENT. If VERSION is nil, remove the version-extended
5301 If optional VIEWTAG is specified, make a view-relative pathname, possibly
5302 replacing the existing view prefix."
5303 (let* ((element (clearcase-vxpath-element-part file))
5304 (glue-fmt (if (and (> (length version) 0)
5305 (= (aref version 0) ?/))
5306 (concat "%s" clearcase-vxpath-glue "%s")
5307 (concat "%s" clearcase-vxpath-glue "/%s")))
5308 (relpath (clearcase-vrpath-tail element)))
5310 (setq element (concat clearcase-viewroot "/" viewtag (or relpath element))))
5312 (format glue-fmt element version)
5315 ;; NYI: This should cache the predecessor version as a property
5318 (defun clearcase-vxpath-of-predecessor (file)
5319 "Compute the version-extended pathname of the predecessor version of FILE."
5320 (if (not (equal 'version (clearcase-fprop-mtype file)))
5321 (error "Not a clearcase version: %s" file))
5322 (let ((abs-file (expand-file-name file)))
5323 (let ((ver (clearcase-utl-1st-line-of-string
5324 (clearcase-ct-cleartool-cmd "describe"
5327 (clearcase-path-native abs-file)))))
5328 (clearcase-path-canonicalise-slashes (concat
5329 (clearcase-vxpath-element-part file)
5330 clearcase-vxpath-glue
5333 (defun clearcase-vxpath-version-extend (file)
5334 "Compute the version-extended pathname of FILE."
5335 (if (not (equal 'version (clearcase-fprop-mtype file)))
5336 (error "Not a clearcase version: %s" file))
5337 (let ((abs-file (expand-file-name file)))
5338 (clearcase-path-canonicalise-slashes
5339 (clearcase-utl-1st-line-of-string
5340 (clearcase-ct-cleartool-cmd "describe"
5343 clearcase-vxpath-glue
5345 (clearcase-path-native abs-file))))))
5347 (defun clearcase-vxpath-of-branch-base (file)
5348 "Compute the version-extended pathname of the version at the branch base of FILE."
5349 (let* ((file-version-path
5350 (if (clearcase-fprop-checked-out file)
5351 ;; If the file is checked-out, start with its predecessor version...
5353 (clearcase-vxpath-version-extend (clearcase-vxpath-of-predecessor file))
5354 ;; ...otherwise start with the file's version.
5356 (clearcase-vxpath-version-extend file)))
5357 (file-version-number (string-to-int (clearcase-vxpath-version file-version-path)))
5358 (branch (clearcase-vxpath-branch file-version-path)))
5359 (let* ((base-number 0)
5360 (base-version-path (format "%s%d" branch base-number)))
5361 (while (and (not (clearcase-file-is-in-snapshot-p base-version-path))
5362 (not (file-exists-p base-version-path))
5363 (< base-number file-version-number))
5364 (setq base-number (1+ base-number))
5365 (setq base-version-path (format "%s%d" branch base-number)))
5366 base-version-path)))
5368 (defun clearcase-vxpath-version-of-branch-base (file)
5369 (clearcase-vxpath-version-part (clearcase-vxpath-of-branch-base file)))
5371 (defun clearcase-vxpath-get-version-in-buffer (vxpath)
5372 "Return a buffer containing the version named by VXPATH.
5373 Intended for use in snapshot views."
5374 (let* ((temp-file (clearcase-vxpath-get-version-in-temp-file vxpath))
5375 (buffer (find-file-noselect temp-file t)))
5377 ;; XEmacs throws an error if you delete a read-only file
5379 (if clearcase-xemacs-p
5380 (if (not (file-writable-p temp-file))
5381 (set-file-modes temp-file (string-to-number "666" 8))))
5383 (delete-file temp-file)
5386 (defun clearcase-vxpath-get-version-in-temp-file (vxpath)
5387 "Return the name of a temporary file containing the version named by VXPATH.
5388 Intended for use in snapshot views."
5390 (let ((temp-file (clearcase-utl-tempfile-name vxpath)))
5392 (clearcase-ct-blocking-call "get"
5394 (clearcase-path-native temp-file)
5395 (clearcase-path-native vxpath))
5400 ;;{{{ Pathnames: viewroot-relative
5402 ;; nyi: make all this work with viewroot-drive-relative files too
5404 (defun clearcase-vrpath-p (path)
5405 "Return whether PATH is viewroot-relative."
5406 (string-match clearcase-vrpath-regexp path))
5408 (defun clearcase-vrpath-head (vrpath)
5409 "Given viewroot-relative PATH, return the prefix including the view-tag."
5410 (if (string-match clearcase-vrpath-regexp vrpath)
5411 (substring vrpath (match-end 0))))
5413 (defun clearcase-vrpath-tail (vrpath)
5414 "Given viewroot-relative PATH, return the suffix after the view-tag."
5415 (if (string-match clearcase-vrpath-regexp vrpath)
5416 (substring vrpath (match-end 0))))
5418 (defun clearcase-vrpath-viewtag (vrpath)
5419 "Given viewroot-relative PATH, return the view-tag."
5420 (if (string-match clearcase-vrpath-regexp vrpath)
5421 (substring vrpath (match-beginning 1) (match-end 1))))
5423 ;; Remove useless viewtags from a pathname.
5424 ;; e.g. if we're setviewed to view "VIEWTAG"
5425 ;; (clearcase-path-remove-useless-viewtags "/view/VIEWTAG/PATH")
5427 ;; (clearcase-path-remove-useless-viewtags "/view/z/view/y/PATH")
5428 ;; ==> /view/y/"PATH"
5430 (defvar clearcase-multiple-viewroot-regexp
5433 clearcase-pname-sep-regexp
5434 clearcase-non-pname-sep-regexp "+"
5437 clearcase-pname-sep-regexp
5441 (defun clearcase-path-remove-useless-viewtags (pathname)
5442 ;; Try to avoid file-name-handler recursion here:
5444 (let ((setview-root clearcase-setview-root))
5448 (setq setview-root (concat setview-root "/")))
5452 ((string-match clearcase-multiple-viewroot-regexp pathname)
5453 (clearcase-path-remove-useless-viewtags (substring pathname (match-beginning 1))))
5456 (string= setview-root "/"))
5459 ;; If pathname has setview-root as a proper prefix,
5460 ;; strip it off and recurse:
5463 (< (length setview-root) (length pathname))
5464 (string= setview-root (substring pathname 0 (length setview-root))))
5465 (clearcase-path-remove-useless-viewtags (substring pathname (- (length setview-root) 1))))
5472 ;; Don't pass the "INPLACE" parameter to subst-char-in-string here since the
5473 ;; parameter is not necessarily a local variable (in some cases it is
5474 ;; buffer-file-name and replacing / with \ in it wreaks havoc).
5476 (defun clearcase-path-canonicalise-slashes (path)
5477 (if (not clearcase-on-mswindows)
5479 (subst-char-in-string ?\\ ?/ path)))
5481 (defun clearcase-path-canonical (path)
5482 (if (not clearcase-on-mswindows)
5484 (if clearcase-on-cygwin
5485 (substring (shell-command-to-string (concat "cygpath -u '" path "'")) 0 -1)
5486 (subst-char-in-string ?\\ ?/ path))))
5488 (defun clearcase-path-native (path)
5489 (if (not clearcase-on-mswindows)
5491 (if clearcase-on-cygwin
5492 (substring (shell-command-to-string (concat "cygpath -w " path)) 0 -1)
5493 (subst-char-in-string ?/ ?\\ path))))
5495 (defun clearcase-path-file-really-exists-p (filename)
5496 "Test if a file really exists, when all file-name handlers are disabled."
5497 (let ((inhibit-file-name-operation 'file-exists-p)
5498 (inhibit-file-name-handlers (mapcar
5501 file-name-handler-alist)))
5502 (file-exists-p filename)))
5504 (defun clearcase-path-file-in-any-scopes (file scopes)
5507 (while (and (null result)
5509 (if (clearcase-path-file-in-scope file (car cursor))
5511 (setq cursor (cdr cursor)))
5515 (defun clearcase-path-file-in-scope (file scope)
5516 (assert (file-name-absolute-p file))
5517 (assert (file-name-absolute-p scope))
5520 ;; Pathnames are equal
5522 (string= file scope)
5524 ;; scope-qua-dir is an ancestor of file (proper string prefix)
5526 (let ((scope-as-dir (concat scope "/")))
5527 (string= scope-as-dir
5528 (substring file 0 (length scope-as-dir))))))
5534 (defun clearcase-mode-line-buffer-id (filename)
5535 "Compute an abbreviated version string for the mode-line.
5536 It will be in one of three forms: /main/NNN, or .../branchname/NNN, or DO-NAME"
5538 (if (clearcase-fprop-checked-out filename)
5539 (if (clearcase-fprop-reserved filename)
5542 (let ((ver-string (clearcase-fprop-version filename)))
5543 (if (not (zerop (length ver-string)))
5544 (let ((i (length ver-string))
5546 ;; Search back from the end to the second-last slash
5550 (if (equal ?/ (aref ver-string (1- i)))
5551 (setq slash-count (1+ slash-count)))
5554 (concat "..." (substring ver-string i))
5555 (substring ver-string i)))))))
5559 ;;{{{ Minibuffer reading
5561 ;;{{{ clearcase-read-version-name
5563 (defun clearcase-read-version-name (prompt file)
5564 "Display PROMPT and read a version string for FILE in the minibuffer,
5565 with completion if possible."
5566 (let* ((insert-default-directory nil)
5567 ;; XEmacs change: disable dialog-box, to avoid
5568 ;; Dialog box error: "Creating file-dialog-box",
5569 ;; "FNERR_INVALIDFILENAME"
5571 (use-dialog-box nil)
5572 (predecessor (clearcase-fprop-predecessor-version
5574 (default-filename (clearcase-vxpath-cons-vxpath file predecessor))
5576 ;; To get this to work it is necessary to make Emacs think
5577 ;; we're completing with respect to "ELEMENT@@/" rather
5578 ;; than "ELEMENT@@". Otherwise when we enter a version
5579 ;; like "/main/NN", it thinks we entered an absolute path.
5580 ;; So instead, we prompt the user to enter "main/..../NN"
5581 ;; and add back the leading slash before returning.
5583 (completing-dir (concat file "@@/")))
5584 ;; XEmacs change: enable completion on Windows.
5585 ;; Works fine with use-dialog-box nil.
5587 (if (clearcase-file-is-in-mvfs-p file)
5588 ;; Completion only works in MVFS:
5590 (concat "/" (read-file-name prompt
5592 (substring predecessor 1)
5595 (substring predecessor 1)))
5596 (concat "/" (read-string prompt
5597 (substring predecessor 1)
5602 ;;{{{ clearcase-read-label-name
5606 (defun clearcase-read-label-name (prompt)
5607 "Read a label name."
5609 (let* ((string (clearcase-ct-cleartool-cmd "lstype"
5614 (mapcar (function (lambda (arg)
5615 (if (string-match "(locked)" arg)
5617 (setq labels (cons (list arg) labels)))))
5618 (clearcase-utl-split-string string "\n"))
5619 (completing-read prompt labels nil t)))
5625 ;;{{{ Directory-tree walking
5627 (defun clearcase-dir-all-files (func &rest args)
5628 "Invoke FUNC f ARGS on each regular file f in default directory."
5629 (let ((dir default-directory))
5630 (message "Scanning directory %s..." dir)
5631 (mapcar (function (lambda (f)
5632 (let ((dirf (expand-file-name f dir)))
5633 (apply func dirf args))))
5634 (directory-files dir))
5635 (message "Scanning directory %s...done" dir)))
5637 (defun clearcase-file-tree-walk-internal (file func args quiet)
5638 (if (not (file-directory-p file))
5639 (apply func file args)
5641 (message "Traversing directory %s..." file))
5642 (let ((dir (file-name-as-directory file)))
5646 (string-equal f ".")
5647 (string-equal f "..")
5648 (member f clearcase-directory-exclusion-list)
5649 (let ((dirf (concat dir f)))
5651 (file-symlink-p dirf) ;; Avoid possible loops
5652 (clearcase-file-tree-walk-internal dirf func args quiet))))))
5653 (directory-files dir)))))
5655 (defun clearcase-file-tree-walk (func &rest args)
5656 "Walk recursively through default directory.
5657 Invoke FUNC f ARGS on each non-directory file f underneath it."
5658 (clearcase-file-tree-walk-internal default-directory func args nil)
5659 (message "Traversing directory %s...done" default-directory))
5661 (defun clearcase-subdir-tree-walk (func &rest args)
5662 "Walk recursively through default directory.
5663 Invoke FUNC f ARGS on each subdirectory underneath it."
5664 (clearcase-subdir-tree-walk-internal default-directory func args nil)
5665 (message "Traversing directory %s...done" default-directory))
5667 (defun clearcase-subdir-tree-walk-internal (file func args quiet)
5668 (if (file-directory-p file)
5669 (let ((dir (file-name-as-directory file)))
5670 (apply func dir args)
5672 (message "Traversing directory %s..." file))
5676 (string-equal f ".")
5677 (string-equal f "..")
5678 (member f clearcase-directory-exclusion-list)
5679 (let ((dirf (concat dir f)))
5681 (file-symlink-p dirf) ;; Avoid possible loops
5682 (clearcase-subdir-tree-walk-internal dirf
5686 (directory-files dir)))))
5690 ;;{{{ Buffer context
5692 ;; nyi: it would be nice if we could restore fold context too, for folded files.
5694 ;; Save a bit of the text around POSN in the current buffer, to help
5695 ;; us find the corresponding position again later. This works even
5696 ;; if all markers are destroyed or corrupted.
5698 (defun clearcase-position-context (posn)
5701 (buffer-substring posn
5702 (min (point-max) (+ posn 100)))))
5704 ;; Return the position of CONTEXT in the current buffer, or nil if we
5705 ;; couldn't find it.
5707 (defun clearcase-find-position-by-context (context)
5708 (let ((context-string (nth 2 context)))
5709 (if (equal "" context-string)
5712 (let ((diff (- (nth 1 context) (buffer-size))))
5713 (if (< diff 0) (setq diff (- diff)))
5714 (goto-char (nth 0 context))
5715 (if (or (search-forward context-string nil t)
5716 ;; Can't use search-backward since the match may continue
5719 (progn (goto-char (- (point) diff (length context-string)))
5720 ;; goto-char doesn't signal an error at
5721 ;; beginning of buffer like backward-char would.
5723 (search-forward context-string nil t)))
5724 ;; to beginning of OSTRING
5726 (- (point) (length context-string))))))))
5730 ;;{{{ Synchronizing buffers with disk
5732 (defun clearcase-sync-after-file-updated-from-vob (file)
5733 ;; Do what is needed after a file in a snapshot is updated or a checkout is
5736 ;; "ct+update" will not always make the file readonly, if, for
5737 ;; example, its contents didn't actually change. But we'd like
5738 ;; update to result in a readonly file, so force it here.
5740 (clearcase-utl-make-unwriteable file)
5743 ;; If this returns true, there was a buffer visiting the file and it it
5744 ;; flushed fprops...
5746 (clearcase-sync-from-disk-if-needed file)
5748 ;; ...otherwise, just sync this other state:
5751 (clearcase-fprop-unstore-properties file)
5752 (dired-relist-file file))))
5754 (defun clearcase-sync-from-disk (file &optional no-confirm)
5756 (clearcase-fprop-unstore-properties file)
5757 ;; If the given file is in any buffer, revert it.
5759 (let ((buffer (find-buffer-visiting file)))
5763 (clearcase-buffer-revert no-confirm)
5764 (clearcase-fprop-get-properties file)
5766 ;; Make sure the mode-line gets updated.
5768 (setq clearcase-mode
5769 (concat " ClearCase:"
5770 (clearcase-mode-line-buffer-id file)))
5771 (force-mode-line-update))))
5773 ;; Update any Dired Mode buffers that list this file.
5775 (dired-relist-file file)
5777 ;; If the file was a directory, update any dired-buffer for
5780 (mapcar (function (lambda (buffer)
5784 (dired-buffers-for-dir file)))
5786 (defun clearcase-sync-from-disk-if-needed (file)
5788 ;; If the buffer on FILE is out of sync with its file, synch it. Returns t if
5789 ;; clearcase-sync-from-disk is called.
5791 (let ((buffer (find-buffer-visiting file)))
5793 ;; Buffer can be out of sync in two ways:
5794 ;; (a) Buffer is modified (hasn't been written)
5795 ;; (b) Buffer is recording a different modtime to what the file has.
5796 ;; This is what happens when the file is updated by another
5798 ;; (c) Buffer and file differ in their writeability.
5800 (or (buffer-modified-p buffer)
5801 (not (verify-visited-file-modtime buffer))
5802 (eq (file-writable-p file)
5803 (with-current-buffer buffer buffer-read-only))))
5805 (clearcase-sync-from-disk file
5806 ;; Only confirm for modified buffers.
5808 (not (buffer-modified-p buffer)))
5813 (defun clearcase-sync-to-disk (&optional not-urgent)
5815 ;; Make sure the current buffer and its working file are in sync
5816 ;; NOT-URGENT means it is ok to continue if the user says not to save.
5818 (if (buffer-modified-p)
5819 (if (or clearcase-suppress-confirm
5820 (y-or-n-p (format "Buffer %s modified; save it? "
5825 (error "Aborted")))))
5828 (defun clearcase-buffer-revert (&optional no-confirm)
5829 ;; Should never call for Dired buffers
5831 (assert (not (eq major-mode 'dired-mode)))
5833 ;; Revert buffer, try to keep point and mark where user expects them in spite
5834 ;; of changes because of expanded version-control key words. This is quite
5835 ;; important since otherwise typeahead won't work as expected.
5838 (let ((point-context (clearcase-position-context (point)))
5840 ;; Use clearcase-utl-mark-marker to avoid confusion in transient-mark-mode.
5841 ;; XEmacs - mark-marker t, FSF Emacs - mark-marker.
5843 (mark-context (if (eq (marker-buffer (clearcase-utl-mark-marker))
5845 (clearcase-position-context (clearcase-utl-mark-marker))))
5846 (camefrom (current-buffer)))
5848 ;; nyi: Should we run font-lock ?
5849 ;; Want to avoid re-doing a buffer that is already correct, such as on
5850 ;; check-in/check-out.
5851 ;; For now do-nothing.
5853 ;; The actual revisit.
5854 ;; For some reason, revert-buffer doesn't recompute whether View Minor Mode
5855 ;; should be on, so turn it off and then turn it on if necessary.
5857 ;; nyi: Perhaps we should re-find-file ?
5859 (or clearcase-xemacs-p
5860 (if (fboundp 'view-mode)
5862 (revert-buffer t no-confirm t)
5863 (or clearcase-xemacs-p
5864 (if (and (boundp 'view-read-only)
5869 ;; Restore point and mark.
5871 (let ((new-point (clearcase-find-position-by-context point-context)))
5873 (goto-char new-point))
5875 (let ((new-mark (clearcase-find-position-by-context mark-context)))
5877 (set-mark new-mark))))
5879 ;; Restore a semblance of folded state.
5881 (if (and (boundp 'folded-file)
5884 (folding-open-buffer)
5885 (folding-whole-buffer)
5887 (folding-goto-char new-point)))))))
5893 ;;{{{ Displaying content in special buffers
5895 (defun clearcase-utl-populate-and-view-buffer (buffer
5897 content-generating-func)
5898 "Empty BUFFER, and populate it by applying to ARGS the CONTENT-GENERATING-FUNC,
5899 and display in a separate window."
5901 (clearcase-utl-edit-and-view-buffer
5907 (apply content-generating-func args)))))
5909 (defun clearcase-utl-edit-and-view-buffer (buffer
5911 content-editing-func)
5912 "Empty BUFFER, and edit it by applying to ARGS the CONTENT-EDITING-FUNC,
5913 and display in a separate window."
5915 (let ( ;; Create the buffer if necessary.
5917 (buf (get-buffer-create buffer))
5919 ;; Record where we came from.
5921 (camefrom (current-buffer)))
5924 (clearcase-view-mode 0 camefrom)
5928 (apply content-editing-func args)
5930 ;; Display the buffer.
5932 (clearcase-port-view-buffer-other-window buf)
5934 (set-buffer-modified-p nil) ; XEmacs - fsf uses `not-modified'
5935 (shrink-window-if-larger-than-buffer)))
5939 ;;{{{ Temporary files
5941 (defvar clearcase-tempfiles nil)
5942 (defun clearcase-utl-tempfile-name (&optional vxpath)
5946 (if (string-match "\\(\\.[^.]+\\)@@" vxpath)
5947 (setq ext (match-string 1 vxpath)))))
5948 (let ((filename (concat
5949 (make-temp-name (clearcase-path-canonical
5950 ;; Use TEMP e.v. if set.
5952 (concat (or (getenv "TEMP") "/tmp")
5955 ;; Store its name for later cleanup.
5957 (setq clearcase-tempfiles (cons filename clearcase-tempfiles))
5960 (defun clearcase-utl-clean-tempfiles ()
5963 (if (file-exists-p tempfile)
5965 (delete-file tempfile)
5967 clearcase-tempfiles)
5968 (setq clearcase-tempfiles nil))
5972 (defun clearcase-utl-touch-file (file)
5973 "Attempt to update the modtime of FILE. Return t if it worked."
5975 ;; Silently fail if there is no "touch" command available. Couldn't find a
5976 ;; convenient way to update a file's modtime in ELisp.
5980 (shell-command (concat "touch " file))
5984 (defun clearcase-utl-filetimes-close (filetime1 filetime2 tolerance)
5985 "Test if FILETIME1 and FILETIME2 are within TOLERANCE of each other."
5986 ;; nyi: To do this correctly we need to know MAXINT.
5987 ;; For now this is correct enough since we only use this as a guideline to
5988 ;; avoid generating a diff.
5990 (if (equal (first filetime1) (first filetime2))
5991 (< (abs (- (second filetime1) (second filetime2))) tolerance)
5994 (defun clearcase-utl-emacs-date-to-clearcase-date (s)
5996 (substring s 20) ;; yyyy
5997 (int-to-string (clearcase-utl-month-unparse (substring s 4 7))) ;; mm
5998 (substring s 8 10) ;; dd
6000 (substring s 11 13) ;; hh
6001 (substring s 14 16) ;; mm
6002 (substring s 17 19))) ;; ss
6004 (defun clearcase-utl-month-unparse (s)
6006 ((string= s "Jan") 1)
6007 ((string= s "Feb") 2)
6008 ((string= s "Mar") 3)
6009 ((string= s "Apr") 4)
6010 ((string= s "May") 5)
6011 ((string= s "Jun") 6)
6012 ((string= s "Jul") 7)
6013 ((string= s "Aug") 8)
6014 ((string= s "Sep") 9)
6015 ((string= s "Oct") 10)
6016 ((string= s "Nov") 11)
6017 ((string= s "Dec") 12)))
6019 (defun clearcase-utl-strip-trailing-slashes (name)
6020 (let* ((len (length name)))
6021 (while (and (> len 1)
6022 (or (equal ?/ (aref name (1- len)))
6023 (equal ?\\ (aref name (1- len)))))
6024 (setq len (1- len)))
6025 (substring name 0 len)))
6027 (defun clearcase-utl-file-size (file)
6028 (nth 7 (file-attributes file)))
6029 (defun clearcase-utl-file-atime (file)
6030 (nth 4 (file-attributes file)))
6031 (defun clearcase-utl-file-mtime (file)
6032 (nth 5 (file-attributes file)))
6033 (defun clearcase-utl-file-ctime (file)
6034 (nth 6 (file-attributes file)))
6036 (defun clearcase-utl-kill-view-buffer ()
6038 (let ((buf (current-buffer)))
6039 (delete-windows-on buf)
6042 (defun clearcase-utl-escape-double-quotes (s)
6043 "Escape any double quotes in string S"
6044 (mapconcat (function (lambda (char)
6045 (if (equal ?\" char)
6051 (defun clearcase-utl-escape-backslashes (s)
6052 "Double any backslashes in string S"
6053 (mapconcat (function (lambda (char)
6054 (if (equal ?\\ char)
6060 (defun clearcase-utl-quote-if-nec (token)
6061 "If TOKEN contains whitespace and is not already quoted,
6062 wrap it in double quotes."
6063 (if (and (string-match "[ \t]" token)
6064 (not (equal ?\" (aref token 0)))
6065 (not (equal ?\' (aref token 0))))
6066 (concat "\"" token "\"")
6069 (defun clearcase-utl-or-func (&rest args)
6070 "A version of `or' that can be applied to a list."
6073 (while (and (null result)
6077 (setq cursor (cdr cursor)))
6080 (defun clearcase-utl-any (predicate list)
6081 "Returns t if PREDICATE is satisfied by any element in LIST."
6084 (while (and (null result)
6086 (if (funcall predicate (car cursor))
6088 (setq cursor (cdr cursor)))
6091 (defun clearcase-utl-every (predicate list)
6092 "Returns t if PREDICATE is satisfied by every element in LIST."
6097 (if (not (funcall predicate (car cursor)))
6099 (setq cursor (cdr cursor)))
6102 (defun clearcase-utl-list-filter (predicate list)
6103 "Map PREDICATE over each element of LIST, and return a list of the elements
6104 that mapped to non-nil."
6107 (while (not (null cursor))
6108 (let ((elt (car cursor)))
6109 (if (funcall predicate elt)
6110 (setq result (cons elt result)))
6111 (setq cursor (cdr cursor))))
6114 (defun clearcase-utl-elts-are-eq (l)
6115 "Test if all elements of LIST are eq."
6118 (let ((head (car l))
6120 (mapcar (function (lambda (elt)
6121 (if (not (eq elt head))
6122 (setq answer nil))))
6126 ;; FSF Emacs - doesn't like parameters on mark-marker.
6128 (defun clearcase-utl-mark-marker ()
6129 (if clearcase-xemacs-p
6133 (defun clearcase-utl-syslog (buf value)
6135 (let ((tmpbuf (get-buffer buf)))
6136 (if (bufferp tmpbuf)
6139 (goto-char (point-max))
6140 (insert (format "%s\n" value)))))))
6142 ;; Extract the first line of a string.
6144 (defun clearcase-utl-1st-line-of-string (s)
6148 (while (and (< i len)
6154 (defun clearcase-utl-split-string (str pat &optional indir suffix)
6157 (last (length str)))
6158 (while (< start last)
6159 (if (string-match pat str start)
6161 (let ((tmp (substring str start (match-beginning 0))))
6162 (if suffix (setq tmp (concat tmp suffix)))
6163 (setq ret (cons (if indir (cons tmp nil)
6166 (setq start (match-end 0)))
6168 (setq ret (cons (substring str start) ret))))
6171 (defun clearcase-utl-split-string-at-char (str char)
6176 ;; Collect next token
6178 (let ((token-begin i))
6181 (while (and (< i eos)
6182 (not (eq char (aref str i))))
6185 (setq ret (cons (substring str token-begin i)
6191 (defun clearcase-utl-add-env (env var)
6194 (vname (substring var 0
6195 (and (string-match "=" var)
6197 (let ((vnl (length vname)))
6199 (if (and (> (length (car a)) vnl)
6200 (string= (substring (car a) 0 vnl)
6202 (throw 'return env))
6207 (defun clearcase-utl-augment-env-from-view-config-spec (old-env tag &optional add-ons)
6209 (cc-env (clearcase-misc-extract-evs-from-config-spe tag)))
6211 ;; 1. Add-on bindings at the front:
6214 (setq newenv (clearcase-utl-add-env newenv (car add-ons)))
6215 (setq add-ons (cdr add-ons)))
6217 ;; 2. Then bindings defined in the config-spec:
6220 (setq newenv (clearcase-utl-add-env newenv (car cc-env)))
6221 (setq cc-env (cdr cc-env)))
6223 ;; 3. Lastly bindings that were in the old environment.
6226 (setq newenv (clearcase-utl-add-env newenv (car old-env)))
6227 (setq old-env (cdr old-env)))
6230 (defun clearcase-utl-make-writeable (file)
6231 ;; Equivalent to chmod u+w
6233 (set-file-modes file
6234 ;; Some users still have Emacs 20 so don't use the octal
6237 (logior 128 (file-modes file))))
6239 (defun clearcase-utl-make-unwriteable (file)
6240 ;; Equivalent to chmod u-w
6242 (set-file-modes file
6243 ;; Some users still have Emacs 20 so don't use the octal
6246 (logand 3967 (file-modes file))))
6254 ;; Predicate to determine if ClearCase menu items are relevant.
6255 ;; nyi" this should disappear
6257 (defun clearcase-buffer-contains-version-p ()
6258 "Return true if the current buffer contains a ClearCase file or directory."
6259 (let ((object-name (if (eq major-mode 'dired-mode)
6262 (clearcase-fprop-file-is-version-p object-name)))
6264 ;;{{{ clearcase-mode menu
6268 ;; This version of the menu will hide rather than grey out inapplicable entries.
6270 (defvar clearcase-menu-contents-minimised
6273 ["Checkin" clearcase-checkin-current-buffer
6275 :visible (clearcase-file-ok-to-checkin buffer-file-name)]
6277 ["Edit checkout comment" clearcase-edit-checkout-comment-current-buffer
6279 :visible (clearcase-file-ok-to-checkin buffer-file-name)]
6281 ["Checkout" clearcase-checkout-current-buffer
6283 :visible (clearcase-file-ok-to-checkout buffer-file-name)]
6285 ["Hijack" clearcase-hijack-current-buffer
6287 :visible (clearcase-file-ok-to-hijack buffer-file-name)]
6289 ["Unhijack" clearcase-unhijack-current-buffer
6291 :visible (clearcase-file-ok-to-unhijack buffer-file-name)]
6293 ["Uncheckout" clearcase-uncheckout-current-buffer
6294 :visible (clearcase-file-ok-to-uncheckout buffer-file-name)]
6296 ["Find checkouts" clearcase-find-checkouts-in-current-view t]
6298 ["Make element" clearcase-mkelem-current-buffer
6299 :visible (clearcase-file-ok-to-mkelem buffer-file-name)]
6301 "---------------------------------"
6302 ["Describe version" clearcase-describe-current-buffer
6303 :visible (clearcase-buffer-contains-version-p)]
6305 ["Describe file" clearcase-describe-current-buffer
6306 :visible (not (clearcase-buffer-contains-version-p))]
6308 ["Annotate version" clearcase-annotate-current-buffer
6309 :visible (clearcase-buffer-contains-version-p)]
6311 ["Show config-spec rule" clearcase-what-rule-current-buffer
6312 :visible (clearcase-buffer-contains-version-p)]
6314 ;; nyi: enable this also when setviewed ?
6316 ["Edit config-spec" clearcase-edcs-edit t]
6318 "---------------------------------"
6319 (list "Compare (Emacs)..."
6320 ["Compare with predecessor" clearcase-ediff-pred-current-buffer
6322 :visible (clearcase-buffer-contains-version-p)]
6323 ["Compare with branch base" clearcase-ediff-branch-base-current-buffer
6325 :visible (clearcase-buffer-contains-version-p)]
6326 ["Compare with named version" clearcase-ediff-named-version-current-buffer
6328 :visible (clearcase-buffer-contains-version-p)])
6329 (list "Compare (GUI)..."
6330 ["Compare with predecessor" clearcase-gui-diff-pred-current-buffer
6332 :visible (clearcase-buffer-contains-version-p)]
6333 ["Compare with branch base" clearcase-gui-diff-branch-base-current-buffer
6335 :visible (clearcase-buffer-contains-version-p)]
6336 ["Compare with named version" clearcase-gui-diff-named-version-current-buffer
6338 :visible (clearcase-buffer-contains-version-p)])
6339 (list "Compare (diff)..."
6340 ["Compare with predecessor" clearcase-diff-pred-current-buffer
6342 :visible (clearcase-buffer-contains-version-p)]
6343 ["Compare with branch base" clearcase-diff-branch-base-current-buffer
6345 :visible (clearcase-buffer-contains-version-p)]
6346 ["Compare with named version" clearcase-diff-named-version-current-buffer
6348 :visible (clearcase-buffer-contains-version-p)])
6349 "---------------------------------"
6350 ["Browse versions (dired)" clearcase-browse-vtree-current-buffer
6351 :visible (clearcase-file-ok-to-browse buffer-file-name)]
6352 ["Vtree browser GUI" clearcase-gui-vtree-browser-current-buffer
6354 :visible (clearcase-buffer-contains-version-p)]
6355 "---------------------------------"
6356 (list "Update snapshot..."
6357 ["Update view" clearcase-update-view
6359 :visible (and (clearcase-file-is-in-view-p default-directory)
6360 (not (clearcase-file-is-in-mvfs-p default-directory)))]
6361 ["Update directory" clearcase-update-default-directory
6363 :visible (and (clearcase-file-is-in-view-p default-directory)
6364 (not (clearcase-file-is-in-mvfs-p default-directory)))]
6365 ["Update this file" clearcase-update-current-buffer
6367 :visible (and (clearcase-file-ok-to-checkout buffer-file-name)
6368 (not (clearcase-file-is-in-mvfs-p buffer-file-name)))]
6370 "---------------------------------"
6371 (list "Element history..."
6372 ["Element history (full)" clearcase-list-history-current-buffer
6374 :visible (clearcase-buffer-contains-version-p)]
6375 ["Element history (branch)" clearcase-list-history-current-buffer
6377 :visible (clearcase-buffer-contains-version-p)]
6378 ["Element history (me)" clearcase-list-history-current-buffer
6380 :visible (clearcase-buffer-contains-version-p)])
6381 "---------------------------------"
6382 ["Show current activity" clearcase-ucm-describe-current-activity
6384 :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6385 ["Make activity" clearcase-ucm-mkact-current-dir
6387 :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6388 ["Set activity..." clearcase-ucm-set-activity-current-dir
6390 :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6391 ["Set NO activity" clearcase-ucm-set-activity-none-current-dir
6393 :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6394 ["Rebase this stream" clearcase-gui-rebase
6396 :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6397 ["Deliver from this stream" clearcase-gui-deliver
6399 :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6400 "---------------------------------"
6401 (list "ClearCase GUI"
6402 ["ClearCase Explorer" clearcase-gui-clearexplorer
6404 :visible clearcase-on-mswindows]
6405 ["Project Explorer" clearcase-gui-project-explorer
6407 ["Merge Manager" clearcase-gui-merge-manager
6409 ["Snapshot View Updater" clearcase-gui-snapshot-view-updater
6411 "---------------------------------"
6414 ;; Enable this when current buffer is on VOB.
6416 ["Make branch type" clearcase-mkbrtype
6419 "---------------------------------"
6420 ["Report Bug in ClearCase Mode" clearcase-submit-bug-report
6423 ["Dump internals" clearcase-dump
6425 :visible (or (equal "rwhitby" (user-login-name))
6426 (equal "esler" (user-login-name)))]
6428 ["Flush caches" clearcase-flush-caches
6430 :visible (or (equal "rwhitby" (user-login-name))
6431 (equal "esler" (user-login-name)))]
6433 "---------------------------------"
6434 ["Customize..." (customize-group 'clearcase)
6437 (defvar clearcase-menu-contents
6440 ["Checkin" clearcase-checkin-current-buffer
6442 :active (clearcase-file-ok-to-checkin buffer-file-name)]
6444 ["Edit checkout comment" clearcase-edit-checkout-comment-current-buffer
6446 :active (clearcase-file-ok-to-checkin buffer-file-name)]
6448 ["Checkout" clearcase-checkout-current-buffer
6450 :active (clearcase-file-ok-to-checkout buffer-file-name)]
6452 ["Hijack" clearcase-hijack-current-buffer
6454 :active (clearcase-file-ok-to-hijack buffer-file-name)]
6456 ["Unhijack" clearcase-unhijack-current-buffer
6458 :active (clearcase-file-ok-to-unhijack buffer-file-name)]
6460 ["Uncheckout" clearcase-uncheckout-current-buffer
6461 :active (clearcase-file-ok-to-uncheckout buffer-file-name)]
6463 ["Make element" clearcase-mkelem-current-buffer
6464 :active (clearcase-file-ok-to-mkelem buffer-file-name)]
6466 "---------------------------------"
6467 ["Describe version" clearcase-describe-current-buffer
6468 :active (clearcase-buffer-contains-version-p)]
6470 ["Describe file" clearcase-describe-current-buffer
6471 :active (not (clearcase-buffer-contains-version-p))]
6473 ["Annotate version" clearcase-annotate-current-buffer
6475 :active (clearcase-buffer-contains-version-p)]
6477 ["Show config-spec rule" clearcase-what-rule-current-buffer
6478 :active (clearcase-buffer-contains-version-p)]
6480 ;; nyi: enable this also when setviewed ?
6482 ["Edit config-spec" clearcase-edcs-edit t]
6484 "---------------------------------"
6485 (list "Compare (Emacs)..."
6486 ["Compare with predecessor" clearcase-ediff-pred-current-buffer
6488 :active (clearcase-buffer-contains-version-p)]
6489 ["Compare with branch base" clearcase-ediff-branch-base-current-buffer
6491 :active (clearcase-buffer-contains-version-p)]
6492 ["Compare with named version" clearcase-ediff-named-version-current-buffer
6494 :active (clearcase-buffer-contains-version-p)])
6495 (list "Compare (GUI)..."
6496 ["Compare with predecessor" clearcase-gui-diff-pred-current-buffer
6498 :active (clearcase-buffer-contains-version-p)]
6499 ["Compare with branch base" clearcase-gui-diff-branch-base-current-buffer
6501 :active (clearcase-buffer-contains-version-p)]
6502 ["Compare with named version" clearcase-gui-diff-named-version-current-buffer
6504 :active (clearcase-buffer-contains-version-p)])
6505 (list "Compare (diff)..."
6506 ["Compare with predecessor" clearcase-diff-pred-current-buffer
6508 :active (clearcase-buffer-contains-version-p)]
6509 ["Compare with branch base" clearcase-diff-branch-base-current-buffer
6511 :active (clearcase-buffer-contains-version-p)]
6512 ["Compare with named version" clearcase-diff-named-version-current-buffer
6514 :active (clearcase-buffer-contains-version-p)])
6515 "---------------------------------"
6516 ["Browse versions (dired)" clearcase-browse-vtree-current-buffer
6517 :active (clearcase-file-ok-to-browse buffer-file-name)]
6518 ["Vtree browser GUI" clearcase-gui-vtree-browser-current-buffer
6520 :active (clearcase-buffer-contains-version-p)]
6521 "---------------------------------"
6522 (list "Update snapshot..."
6523 ["Update view" clearcase-update-view
6525 :active (and (clearcase-file-is-in-view-p default-directory)
6526 (not (clearcase-file-is-in-mvfs-p default-directory)))]
6527 ["Update directory" clearcase-update-default-directory
6529 :active (and (clearcase-file-is-in-view-p default-directory)
6530 (not (clearcase-file-is-in-mvfs-p default-directory)))]
6531 ["Update this file" clearcase-update-current-buffer
6533 :active (and (clearcase-file-ok-to-checkout buffer-file-name)
6534 (not (clearcase-file-is-in-mvfs-p buffer-file-name)))]
6536 "---------------------------------"
6537 (list "Element history..."
6538 ["Element history (full)" clearcase-list-history-current-buffer
6540 :active (clearcase-buffer-contains-version-p)]
6541 ["Element history (branch)" clearcase-list-history-current-buffer
6543 :active (clearcase-buffer-contains-version-p)]
6544 ["Element history (me)" clearcase-list-history-current-buffer
6546 :active (clearcase-buffer-contains-version-p)])
6547 "---------------------------------"
6548 ["Show current activity" clearcase-ucm-describe-current-activity
6550 :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6551 ["Make activity" clearcase-ucm-mkact-current-dir
6553 :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6554 ["Set activity..." clearcase-ucm-set-activity-current-dir
6556 :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6557 ["Set NO activity" clearcase-ucm-set-activity-none-current-dir
6559 :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6560 ["Rebase this stream" clearcase-gui-rebase
6562 :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6563 ["Deliver from this stream" clearcase-gui-deliver
6565 :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6566 "---------------------------------"
6567 (list "ClearCase GUI"
6568 ["ClearCase Explorer" clearcase-gui-clearexplorer
6570 :active clearcase-on-mswindows]
6571 ["Project Explorer" clearcase-gui-project-explorer
6573 ["Merge Manager" clearcase-gui-merge-manager
6575 ["Snapshot View Updater" clearcase-gui-snapshot-view-updater
6577 "---------------------------------"
6580 ;; Enable this when current buffer is on VOB.
6582 ["Make branch type" clearcase-mkbrtype
6585 "---------------------------------"
6586 ["Report Bug in ClearCase Mode" clearcase-submit-bug-report
6589 ["Dump internals" clearcase-dump
6591 :active (or (equal "rwhitby" (user-login-name))
6592 (equal "esler" (user-login-name)))]
6594 ["Flush caches" clearcase-flush-caches
6596 :active (or (equal "rwhitby" (user-login-name))
6597 (equal "esler" (user-login-name)))]
6599 "---------------------------------"
6600 ["Customize..." (customize-group 'clearcase)
6603 (if (and clearcase-minimise-menus
6604 (not clearcase-xemacs-p))
6605 (setq clearcase-menu-contents clearcase-menu-contents-minimised))
6609 (if (>= emacs-major-version '20)
6615 (list clearcase-mode-map)
6617 clearcase-menu-contents)
6619 (or clearcase-xemacs-p
6620 (add-to-list 'menu-bar-final-items 'ClearCase))))
6624 ;;{{{ clearcase-dired-mode menu
6626 ;;{{{ Related functions
6628 ;; nyi: this probably gets run for each menu element.
6629 ;; For better efficiency, look into using a one-pass ":filter"
6630 ;; to construct this menu dynamically.
6632 (defun clearcase-dired-mark-count ()
6633 (let ((old-point (point))
6635 (goto-char (point-min))
6636 (while (re-search-forward
6637 (concat "^" (regexp-quote (char-to-string
6638 dired-marker-char))) nil t)
6639 (setq count (1+ count)))
6640 (goto-char old-point)
6643 (defun clearcase-dired-current-ok-to-checkin ()
6644 (let ((file (dired-get-filename nil t)))
6646 (clearcase-file-ok-to-checkin file))))
6648 (defun clearcase-dired-current-ok-to-checkout ()
6649 (let ((file (dired-get-filename nil t)))
6651 (clearcase-file-ok-to-checkout file))))
6653 (defun clearcase-dired-current-ok-to-uncheckout ()
6654 (let ((file (dired-get-filename nil t)))
6656 (clearcase-file-ok-to-uncheckout file))))
6658 (defun clearcase-dired-current-ok-to-hijack ()
6659 (let ((file (dired-get-filename nil t)))
6661 (clearcase-file-ok-to-hijack file))))
6663 (defun clearcase-dired-current-ok-to-unhijack ()
6664 (let ((file (dired-get-filename nil t)))
6666 (clearcase-file-ok-to-unhijack file))))
6668 (defun clearcase-dired-current-ok-to-mkelem ()
6669 (let ((file (dired-get-filename nil t)))
6671 (clearcase-file-ok-to-mkelem file))))
6673 (defun clearcase-dired-current-ok-to-browse ()
6674 (let ((file (dired-get-filename nil t)))
6675 (clearcase-file-ok-to-browse file)))
6677 (defvar clearcase-dired-max-marked-files-to-check 5
6678 "The maximum number of marked files in a Dired buffer when constructing
6679 the ClearCase menu.")
6681 ;; nyi: speed these up by stopping check when a non-qualifying file is found
6683 ;; - hook the menu constuction and figure out what ops apply
6684 ;; - hook mark/unmark/move cursor
6686 (defun clearcase-dired-marked-ok-to-checkin ()
6687 (let ((files (dired-get-marked-files)))
6688 (or (> (length files) clearcase-dired-max-marked-files-to-check)
6689 (clearcase-utl-every (function clearcase-file-ok-to-checkin)
6692 (defun clearcase-dired-marked-ok-to-checkout ()
6693 (let ((files (dired-get-marked-files)))
6694 (or (> (length files) clearcase-dired-max-marked-files-to-check)
6695 (clearcase-utl-every (function clearcase-file-ok-to-checkout)
6698 (defun clearcase-dired-marked-ok-to-uncheckout ()
6699 (let ((files (dired-get-marked-files)))
6700 (or (> (length files) clearcase-dired-max-marked-files-to-check)
6701 (clearcase-utl-every (function clearcase-file-ok-to-uncheckout)
6704 (defun clearcase-dired-marked-ok-to-hijack ()
6705 (let ((files (dired-get-marked-files)))
6706 (or (> (length files) clearcase-dired-max-marked-files-to-check)
6707 (clearcase-utl-every (function clearcase-file-ok-to-hijack)
6710 (defun clearcase-dired-marked-ok-to-unhijack ()
6711 (let ((files (dired-get-marked-files)))
6712 (or (> (length files) clearcase-dired-max-marked-files-to-check)
6713 (clearcase-utl-every (function clearcase-file-ok-to-unhijack)
6716 (defun clearcase-dired-marked-ok-to-mkelem ()
6717 (let ((files (dired-get-marked-files)))
6718 (or (> (length files) clearcase-dired-max-marked-files-to-check)
6719 (clearcase-utl-every (function clearcase-file-ok-to-mkelem)
6722 (defun clearcase-dired-current-dir-ok-to-checkin ()
6723 (let ((dir (dired-current-directory)))
6724 (clearcase-file-ok-to-checkin dir)))
6726 (defun clearcase-dired-current-dir-ok-to-checkout ()
6727 (let ((dir (dired-current-directory)))
6728 (clearcase-file-ok-to-checkout dir)))
6730 (defun clearcase-dired-current-dir-ok-to-uncheckout ()
6731 (let ((dir (dired-current-directory)))
6732 (clearcase-file-ok-to-uncheckout dir)))
6738 ;; This version of the menu will hide rather than grey out inapplicable entries.
6740 (defvar clearcase-dired-menu-contents-minimised
6745 ["Checkin file" clearcase-checkin-dired-files
6747 :visible (and (< (clearcase-dired-mark-count) 2)
6748 (clearcase-dired-current-ok-to-checkin))]
6750 ["Edit checkout comment" clearcase-edit-checkout-comment-dired-file
6752 :visible (and (< (clearcase-dired-mark-count) 2)
6753 (clearcase-dired-current-ok-to-checkin))]
6755 ["Checkout file" clearcase-checkout-dired-files
6757 :visible (and (< (clearcase-dired-mark-count) 2)
6758 (clearcase-dired-current-ok-to-checkout))]
6760 ["Uncheckout file" clearcase-uncheckout-dired-files
6762 :visible (and (< (clearcase-dired-mark-count) 2)
6763 (clearcase-dired-current-ok-to-uncheckout))]
6765 ["Hijack file" clearcase-hijack-dired-files
6767 :visible (and (< (clearcase-dired-mark-count) 2)
6768 (clearcase-dired-current-ok-to-hijack))]
6770 ["Unhijack file" clearcase-unhijack-dired-files
6772 :visible (and (< (clearcase-dired-mark-count) 2)
6773 (clearcase-dired-current-ok-to-unhijack))]
6775 ["Find checkouts" clearcase-find-checkouts-in-current-view t]
6777 ["Make file an element" clearcase-mkelem-dired-files
6778 :visible (and (< (clearcase-dired-mark-count) 2)
6779 (clearcase-dired-current-ok-to-mkelem))]
6783 ["Checkin marked files" clearcase-checkin-dired-files
6785 :visible (and (>= (clearcase-dired-mark-count) 2)
6786 (clearcase-dired-marked-ok-to-checkin))]
6788 ["Checkout marked files" clearcase-checkout-dired-files
6790 :visible (and (>= (clearcase-dired-mark-count) 2)
6791 (clearcase-dired-marked-ok-to-checkout))]
6793 ["Uncheckout marked files" clearcase-uncheckout-dired-files
6795 :visible (and (>= (clearcase-dired-mark-count) 2)
6796 (clearcase-dired-marked-ok-to-uncheckout))]
6798 ["Hijack marked files" clearcase-hijack-dired-files
6800 :visible (and (>= (clearcase-dired-mark-count) 2)
6801 (clearcase-dired-marked-ok-to-hijack))]
6803 ["Unhijack marked files" clearcase-unhijack-dired-files
6805 :visible (and (>= (clearcase-dired-mark-count) 2)
6806 (clearcase-dired-marked-ok-to-unhijack))]
6808 ["Make marked files elements" clearcase-mkelem-dired-files
6810 :visible (and (>= (clearcase-dired-mark-count) 2)
6811 (clearcase-dired-marked-ok-to-mkelem))]
6814 ;; Current directory
6816 ["Checkin current-dir" clearcase-dired-checkin-current-dir
6818 :visible (clearcase-dired-current-dir-ok-to-checkin)]
6820 ["Checkout current dir" clearcase-dired-checkout-current-dir
6822 :visible (clearcase-dired-current-dir-ok-to-checkout)]
6824 ["Uncheckout current dir" clearcase-dired-uncheckout-current-dir
6826 :visible (clearcase-dired-current-dir-ok-to-uncheckout)]
6828 "---------------------------------"
6829 ["Describe file" clearcase-describe-dired-file
6832 ["Annotate file" clearcase-annotate-dired-file
6835 ["Show config-spec rule" clearcase-what-rule-dired-file
6839 ["Edit config-spec" clearcase-edcs-edit t]
6841 "---------------------------------"
6842 (list "Compare (Emacs)..."
6843 ["Compare with predecessor" clearcase-ediff-pred-dired-file
6846 ["Compare with branch base" clearcase-ediff-branch-base-dired-file
6849 ["Compare with named version" clearcase-ediff-named-version-dired-file
6852 (list "Compare (GUI)..."
6853 ["Compare with predecessor" clearcase-gui-diff-pred-dired-file
6856 ["Compare with branch base" clearcase-gui-diff-branch-base-dired-file
6859 ["Compare with named version" clearcase-gui-diff-named-version-dired-file
6862 (list "Compare (diff)..."
6863 ["Compare with predecessor" clearcase-diff-pred-dired-file
6866 ["Compare with branch base" clearcase-diff-branch-base-dired-file
6869 ["Compare with named version" clearcase-diff-named-version-dired-file
6872 "---------------------------------"
6873 ["Browse versions (dired)" clearcase-browse-vtree-dired-file
6874 :visible (clearcase-dired-current-ok-to-browse)]
6875 ["Vtree browser GUI" clearcase-gui-vtree-browser-dired-file
6878 "---------------------------------"
6879 (list "Update snapshot..."
6880 ["Update view" clearcase-update-view
6882 :visible (and (clearcase-file-is-in-view-p default-directory)
6883 (not (clearcase-file-is-in-mvfs-p default-directory)))]
6884 ["Update directory" clearcase-update-default-directory
6886 :visible (and (clearcase-file-is-in-view-p default-directory)
6887 (not (clearcase-file-is-in-mvfs-p default-directory)))]
6888 ["Update file" clearcase-update-dired-files
6890 :visible (and (< (clearcase-dired-mark-count) 2)
6891 (clearcase-dired-current-ok-to-checkout)
6892 (not (clearcase-file-is-in-mvfs-p default-directory)))]
6893 ["Update marked files" clearcase-update-dired-files
6895 :visible (and (>= (clearcase-dired-mark-count) 2)
6896 (not (clearcase-file-is-in-mvfs-p default-directory)))]
6898 "---------------------------------"
6899 (list "Element history..."
6900 ["Element history (full)" clearcase-list-history-dired-file
6903 ["Element history (branch)" clearcase-list-history-dired-file
6906 ["Element history (me)" clearcase-list-history-dired-file
6909 "---------------------------------"
6910 ["Show current activity" clearcase-ucm-describe-current-activity
6912 :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6913 ["Make activity" clearcase-ucm-mkact-current-dir
6915 :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6916 ["Set activity..." clearcase-ucm-set-activity-current-dir
6918 :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6919 ["Set NO activity" clearcase-ucm-set-activity-none-current-dir
6921 :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6922 ["Rebase this stream" clearcase-gui-rebase
6924 :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6925 ["Deliver from this stream" clearcase-gui-deliver
6927 :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6928 "---------------------------------"
6929 (list "ClearCase GUI"
6930 ["ClearCase Explorer" clearcase-gui-clearexplorer
6932 :visible clearcase-on-mswindows]
6933 ["Project Explorer" clearcase-gui-project-explorer
6935 ["Merge Manager" clearcase-gui-merge-manager
6937 ["Snapshot View Updater" clearcase-gui-snapshot-view-updater
6939 "---------------------------------"
6941 ["Make branch type" clearcase-mkbrtype
6944 "---------------------------------"
6945 ["Report Bug in ClearCase Mode" clearcase-submit-bug-report
6948 ["Dump internals" clearcase-dump
6950 :visible (or (equal "rwhitby" (user-login-name))
6951 (equal "esler" (user-login-name)))]
6953 ["Flush caches" clearcase-flush-caches
6955 :visible (or (equal "rwhitby" (user-login-name))
6956 (equal "esler" (user-login-name)))]
6958 "---------------------------------"
6959 ["Customize..." (customize-group 'clearcase)
6962 (defvar clearcase-dired-menu-contents
6967 ["Checkin file" clearcase-checkin-dired-files
6969 :active (and (< (clearcase-dired-mark-count) 2)
6970 (clearcase-dired-current-ok-to-checkin))]
6972 ["Edit checkout comment" clearcase-edit-checkout-comment-dired-file
6974 :active (and (< (clearcase-dired-mark-count) 2)
6975 (clearcase-dired-current-ok-to-checkin))]
6977 ["Checkout file" clearcase-checkout-dired-files
6979 :active (and (< (clearcase-dired-mark-count) 2)
6980 (clearcase-dired-current-ok-to-checkout))]
6982 ["Uncheckout file" clearcase-uncheckout-dired-files
6984 :active (and (< (clearcase-dired-mark-count) 2)
6985 (clearcase-dired-current-ok-to-uncheckout))]
6987 ["Hijack file" clearcase-hijack-dired-files
6989 :active (and (< (clearcase-dired-mark-count) 2)
6990 (clearcase-dired-current-ok-to-hijack))]
6992 ["Unhijack file" clearcase-unhijack-dired-files
6994 :active (and (< (clearcase-dired-mark-count) 2)
6995 (clearcase-dired-current-ok-to-unhijack))]
6997 ["Make file an element" clearcase-mkelem-dired-files
6998 :active (and (< (clearcase-dired-mark-count) 2)
6999 (clearcase-dired-current-ok-to-mkelem))]
7003 ["Checkin marked files" clearcase-checkin-dired-files
7005 :active (and (>= (clearcase-dired-mark-count) 2)
7006 (clearcase-dired-marked-ok-to-checkin))]
7008 ["Checkout marked files" clearcase-checkout-dired-files
7010 :active (and (>= (clearcase-dired-mark-count) 2)
7011 (clearcase-dired-marked-ok-to-checkout))]
7013 ["Uncheckout marked files" clearcase-uncheckout-dired-files
7015 :active (and (>= (clearcase-dired-mark-count) 2)
7016 (clearcase-dired-marked-ok-to-uncheckout))]
7018 ["Hijack marked files" clearcase-hijack-dired-files
7020 :active (and (>= (clearcase-dired-mark-count) 2)
7021 (clearcase-dired-marked-ok-to-hijack))]
7023 ["Unhijack marked files" clearcase-unhijack-dired-files
7025 :active (and (>= (clearcase-dired-mark-count) 2)
7026 (clearcase-dired-marked-ok-to-unhijack))]
7028 ["Make marked files elements" clearcase-mkelem-dired-files
7030 :active (and (>= (clearcase-dired-mark-count) 2)
7031 (clearcase-dired-marked-ok-to-mkelem))]
7034 ;; Current directory
7036 ["Checkin current-dir" clearcase-dired-checkin-current-dir
7038 :active (clearcase-dired-current-dir-ok-to-checkin)]
7040 ["Checkout current dir" clearcase-dired-checkout-current-dir
7042 :active (clearcase-dired-current-dir-ok-to-checkout)]
7044 ["Uncheckout current dir" clearcase-dired-uncheckout-current-dir
7046 :active (clearcase-dired-current-dir-ok-to-uncheckout)]
7048 "---------------------------------"
7049 ["Describe file" clearcase-describe-dired-file
7052 ["Annotate file" clearcase-annotate-dired-file
7055 ["Show config-spec rule" clearcase-what-rule-dired-file
7059 ["Edit config-spec" clearcase-edcs-edit t]
7061 "---------------------------------"
7062 (list "Compare (Emacs)..."
7063 ["Compare with predecessor" clearcase-ediff-pred-dired-file
7066 ["Compare with branch base" clearcase-ediff-branch-base-dired-file
7069 ["Compare with named version" clearcase-ediff-named-version-dired-file
7072 (list "Compare (GUI)..."
7073 ["Compare with predecessor" clearcase-gui-diff-pred-dired-file
7076 ["Compare with branch base" clearcase-gui-diff-branch-base-dired-file
7079 ["Compare with named version" clearcase-gui-diff-named-version-dired-file
7082 (list "Compare (diff)..."
7083 ["Compare with predecessor" clearcase-diff-pred-dired-file
7086 ["Compare with branch base" clearcase-diff-branch-base-dired-file
7089 ["Compare with named version" clearcase-diff-named-version-dired-file
7092 "---------------------------------"
7093 ["Browse versions (dired)" clearcase-browse-vtree-dired-file
7094 :active (clearcase-dired-current-ok-to-browse)]
7095 ["Vtree browser GUI" clearcase-gui-vtree-browser-dired-file
7098 "---------------------------------"
7099 (list "Update snapshot..."
7100 ["Update view" clearcase-update-view
7102 :active (and (clearcase-file-is-in-view-p default-directory)
7103 (not (clearcase-file-is-in-mvfs-p default-directory)))]
7104 ["Update directory" clearcase-update-default-directory
7106 :active (and (clearcase-file-is-in-view-p default-directory)
7107 (not (clearcase-file-is-in-mvfs-p default-directory)))]
7108 ["Update file" clearcase-update-dired-files
7110 :active (and (< (clearcase-dired-mark-count) 2)
7111 (clearcase-dired-current-ok-to-checkout)
7112 (not (clearcase-file-is-in-mvfs-p default-directory)))]
7113 ["Update marked files" clearcase-update-dired-files
7115 :active (and (>= (clearcase-dired-mark-count) 2)
7116 (not (clearcase-file-is-in-mvfs-p default-directory)))]
7118 "---------------------------------"
7119 (list "Element history..."
7120 ["Element history (full)" clearcase-list-history-dired-file
7123 ["Element history (branch)" clearcase-list-history-dired-file
7126 ["Element history (me)" clearcase-list-history-dired-file
7129 "---------------------------------"
7130 ["Show current activity" clearcase-ucm-describe-current-activity
7132 :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
7133 ["Make activity" clearcase-ucm-mkact-current-dir
7135 :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
7136 ["Set activity..." clearcase-ucm-set-activity-current-dir
7138 :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
7139 ["Set NO activity" clearcase-ucm-set-activity-none-current-dir
7141 :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
7142 ["Rebase this stream" clearcase-gui-rebase
7144 :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
7145 ["Deliver from this stream" clearcase-gui-deliver
7147 :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
7148 "---------------------------------"
7149 (list "ClearCase GUI"
7150 ["ClearCase Explorer" clearcase-gui-clearexplorer
7152 :active clearcase-on-mswindows]
7153 ["Project Explorer" clearcase-gui-project-explorer
7155 ["Merge Manager" clearcase-gui-merge-manager
7157 ["Snapshot View Updater" clearcase-gui-snapshot-view-updater
7159 "---------------------------------"
7161 ["Make branch type" clearcase-mkbrtype
7164 "---------------------------------"
7165 ["Report Bug in ClearCase Mode" clearcase-submit-bug-report
7168 ["Dump internals" clearcase-dump
7170 :active (or (equal "rwhitby" (user-login-name))
7171 (equal "esler" (user-login-name)))]
7173 ["Flush caches" clearcase-flush-caches
7175 :active (or (equal "rwhitby" (user-login-name))
7176 (equal "esler" (user-login-name)))]
7178 "---------------------------------"
7179 ["Customize..." (customize-group 'clearcase)
7182 (if (and clearcase-minimise-menus
7183 (not clearcase-xemacs-p))
7184 (setq clearcase-dired-menu-contents clearcase-dired-menu-contents-minimised))
7188 (if (>= emacs-major-version '20)
7191 clearcase-dired-menu
7192 (list clearcase-dired-mode-map)
7193 "ClearCase Dired menu"
7194 clearcase-dired-menu-contents)
7196 (or clearcase-xemacs-p
7197 (add-to-list 'menu-bar-final-items 'ClearCase))))
7205 ;;{{{ Single-selection buffer widget
7207 ;; Keep the compiler quiet by declaring these
7208 ;; buffer-local variables here thus.
7210 (defvar clearcase-selection-window-config nil)
7211 (defvar clearcase-selection-interpreter nil)
7212 (defvar clearcase-selection-continuation nil)
7213 (defvar clearcase-selection-operands nil)
7215 (defun clearcase-ucm-make-selection-window (buffer-name
7217 selection-interpreter
7220 (let ((buf (get-buffer-create buffer-name)))
7226 (setq buffer-read-only nil)
7228 (setq truncate-lines t)
7232 (goto-char (point-min))
7233 (insert buffer-contents)
7235 ;; Insert mouse-highlighting
7238 (goto-char (point-min))
7239 (while (< (point) (point-max))
7243 (put-text-property (point)
7247 'mouse-face 'highlight))
7253 (setq buffer-read-only t)
7254 (use-local-map clearcase-selection-keymap)
7256 ;; Set up the interpreter and continuation
7258 (set (make-local-variable 'clearcase-selection-window-config)
7259 (current-window-configuration))
7260 (set (make-local-variable 'clearcase-selection-interpreter)
7261 selection-interpreter)
7262 (set (make-local-variable 'clearcase-selection-continuation)
7264 (set (make-local-variable 'clearcase-selection-operands)
7267 ;; Display the buffer
7271 (shrink-window-if-larger-than-buffer)
7272 (message "Use RETURN to select an item")))
7274 (defun clearcase-selection-continue ()
7278 ;; Call the interpreter to extract the item of interest
7281 (let ((item (funcall clearcase-selection-interpreter)))
7282 ;; Call the continuation.
7284 (apply clearcase-selection-continuation
7285 (append clearcase-selection-operands (list item))))
7287 ;; Restore window config
7289 (let ((sel-buffer (current-buffer)))
7290 (if clearcase-selection-window-config
7291 (set-window-configuration clearcase-selection-window-config))
7292 (delete-windows-on sel-buffer)
7293 (kill-buffer sel-buffer)))
7295 (defun clearcase-selection-mouse-continue (click)
7297 (mouse-set-point click)
7298 (clearcase-selection-continue))
7300 (defvar clearcase-selection-keymap
7301 (let ((map (make-sparse-keymap)))
7302 (define-key map [return] 'clearcase-selection-continue)
7303 (define-key map [mouse-2] 'clearcase-selection-mouse-continue)
7304 (define-key map "q" 'clearcase-utl-kill-view-buffer)
7305 ;; nyi: refresh list
7306 ;; (define-key map "g" 'clearcase-selection-get)
7313 ;;{{{ Integration with Emacs
7315 ;;{{{ Functions: examining the ClearCase installation
7317 ;; Discover ClearCase version-string
7319 (defun clearcase-get-version-string ()
7320 ;; Some care seems to be necessary to avoid problems caused by odd settings
7321 ;; of the "SHELL" environment variable. I found that simply
7322 ;; (shell-command-to-string "cleartool -version") on Windows-2000 with
7323 ;; SHELL==cmd.exe just returned a copy of the Windows command prompt. The
7324 ;; result was that clearcase-integrate would not complete.
7326 ;; The follow seems to work.
7328 (if clearcase-on-mswindows
7329 (shell-command-to-string "cmd /c cleartool -version")
7330 (shell-command-to-string "sh -c \"cleartool -version\"")))
7332 ;; Find where cleartool is installed.
7334 (defun clearcase-find-cleartool ()
7335 "Search directories listed in the PATH environment variable
7336 looking for a cleartool executable. If found return the full pathname."
7337 (let ((dir-list (parse-colon-path (getenv "PATH")))
7338 (cleartool-name (if clearcase-on-mswindows
7341 (cleartool-path nil))
7344 (function (lambda (dir)
7345 (let ((f (expand-file-name (concat dir cleartool-name))))
7346 (if (file-executable-p f)
7348 (setq cleartool-path f)
7349 (throw 'found t))))))
7354 (defun clearcase-non-lt-registry-server-online-p ()
7355 "Heuristic to determine if the local host is network-connected to
7356 its ClearCase servers. Used for a non-LT system."
7359 (buf (get-buffer-create " *clearcase-lsregion*")))
7363 (let ((process (start-process "lsregion"
7368 (timeout-occurred nil))
7370 ;; Now wait a little while, if necessary, for some output.
7372 (while (and (null result)
7373 (not timeout-occurred)
7374 (< (buffer-size) (length "Tag: ")))
7375 (if (null (accept-process-output process 10))
7376 (setq timeout-occurred t))
7377 (goto-char (point-min))
7378 (if (looking-at "Tag: ")
7381 (kill-process process)
7383 ;; If servers are apparently not online, keep the
7384 ;; buffer around so we can see what lsregion reported.
7386 (sit-for 0.01); Fix by AJM to prevent kill-buffer claiming process still running
7391 ;; We could have an LT system, which lacks ct+lsregion, but has ct+lssite.
7393 (defun clearcase-lt-registry-server-online-p ()
7394 "Heuristic to determine if the local host is network-connected to
7395 its ClearCase servers. Used for LT system."
7398 (buf (get-buffer-create " *clearcase-lssite*")))
7402 (let ((process (start-process "lssite"
7407 (timeout-occurred nil))
7409 ;; Now wait a little while, if necessary, for some output.
7411 (while (and (null result)
7412 (not timeout-occurred)
7413 (< (buffer-size) (length " view_cache_size")))
7414 (if (null (accept-process-output process 10))
7415 (setq timeout-occurred t))
7416 (goto-char (point-min))
7417 (if (re-search-forward "view_cache_size" nil t)
7420 (kill-process process)
7423 ;; If servers are apparently not online, keep the
7424 ;; buffer around so we can see what lssite reported.
7426 (sit-for 0.01); Fix by AJM to prevent kill-buffer claiming process still running
7431 ;; Find out if the ClearCase registry server is accessible.
7432 ;; We could be on a disconnected laptop.
7434 (defun clearcase-registry-server-online-p ()
7435 "Heuristic to determine if the local host is network-connected to
7436 its ClearCase server(s)."
7439 (clearcase-lt-registry-server-online-p)
7440 (clearcase-non-lt-registry-server-online-p)))
7443 ;;{{{ Functions: hooks
7445 ;;{{{ A find-file hook to turn on clearcase-mode
7447 (defun clearcase-hook-find-file-hook ()
7448 (let ((filename (buffer-file-name)))
7451 (clearcase-fprop-unstore-properties filename)
7452 (if (clearcase-file-would-be-in-view-p filename)
7454 ;; 1. Activate minor mode
7458 ;; 2. Pre-fetch file properties
7460 (if (file-exists-p filename)
7462 (clearcase-fprop-get-properties filename)
7464 ;; 3. Put branch/ver in mode-line
7466 (setq clearcase-mode
7467 (concat " ClearCase:"
7468 (clearcase-mode-line-buffer-id filename)))
7469 (force-mode-line-update)
7471 ;; 4. Schedule the asynchronous fetching of the view's properties
7472 ;; next time Emacs is idle enough.
7474 (clearcase-vprop-schedule-work (clearcase-fprop-viewtag filename))
7476 ;; 5. Set backup policy
7478 (unless clearcase-make-backup-files
7479 (make-local-variable 'backup-inhibited)
7480 (setq backup-inhibited t))))
7482 (clearcase-set-auto-mode)))))))
7484 (defun clearcase-set-auto-mode ()
7485 "Check again for the mode of the current buffer when using ClearCase version extended paths."
7487 (let* ((version (clearcase-vxpath-version-part (buffer-file-name)))
7488 (buffer-file-name (clearcase-vxpath-element-part (buffer-file-name))))
7490 ;; Need to recheck the major mode only if a version was appended.
7497 ;;{{{ A find-file hook for version-extended pathnames
7499 (defun clearcase-hook-vxpath-find-file-hook ()
7500 (if (clearcase-vxpath-p default-directory)
7501 (let ((element (clearcase-vxpath-element-part default-directory))
7502 (version (clearcase-vxpath-version-part default-directory)))
7504 ;; 1. Set the buffer name to <filename>@@/<branch path>/<version>.
7506 (let ((new-buffer-name
7507 (concat (file-name-nondirectory element)
7508 clearcase-vxpath-glue
7512 (or (string= new-buffer-name (buffer-name))
7514 ;; Uniquify the name, if necessary.
7517 (uniquifier-string ""))
7518 (while (get-buffer (concat new-buffer-name uniquifier-string))
7519 (setq uniquifier-string (format "<%d>" n))
7522 (concat new-buffer-name uniquifier-string)))))
7524 ;; 2. Set the default directory to the dir containing <filename>.
7526 (let ((new-dir (file-name-directory element)))
7527 (setq default-directory new-dir))
7529 ;; 3. Disable auto-saving.
7531 ;; If we're visiting <filename>@@/<branch path>/199
7532 ;; we don't want Emacs trying to find a place to create a "#199#.
7534 (auto-save-mode 0))))
7538 ;;{{{ A dired-mode-hook to turn on clearcase-dired-mode
7540 (defun clearcase-hook-dired-mode-hook ()
7541 ;; Force a re-computation of whether the directory is within ClearCase.
7543 (clearcase-fprop-unstore-properties default-directory)
7545 ;; Wrap this in an exception handler. Otherwise, diredding into
7546 ;; a deregistered or otherwise defective snapshot-view fails.
7549 ;; If this directory is below a ClearCase element,
7550 ;; 1. turn on ClearCase Dired Minor Mode.
7551 ;; 2. display branch/ver in mode-line
7553 (if (clearcase-file-would-be-in-view-p default-directory)
7555 (if clearcase-auto-dired-mode
7557 (clearcase-dired-mode 1)
7558 (clearcase-fprop-get-properties default-directory)
7559 (clearcase-vprop-schedule-work (clearcase-fprop-viewtag default-directory))))
7560 (setq clearcase-dired-mode
7561 (concat " ClearCase:"
7562 (clearcase-mode-line-buffer-id default-directory)))
7563 (force-mode-line-update)))
7564 (error (message "Error fetching ClearCase properties of %s" default-directory))))
7568 ;;{{{ A dired-after-readin-hook to add ClearCase information to the display
7570 (defun clearcase-hook-dired-after-readin-hook ()
7572 ;; If in clearcase-dired-mode, reformat the buffer.
7574 (if clearcase-dired-mode
7576 (clearcase-dired-reformat-buffer)
7577 (if clearcase-dired-show-view
7578 (clearcase-dired-insert-viewtag))))
7583 ;;{{{ A write-file-hook to auto-insert a version-string.
7585 ;; To use this, put a line containing this in the first 8 lines of your file:
7586 ;; ClearCase-version: </main/laptop/165>
7587 ;; and make sure that clearcase-version-stamp-active gets set to true at least
7588 ;; locally in the file.
7590 (defvar clearcase-version-stamp-line-limit 1000)
7591 (defvar clearcase-version-stamp-begin-regexp "ClearCase-version:[ \t]<")
7592 (defvar clearcase-version-stamp-end-regexp ">")
7593 (defvar clearcase-version-stamp-active nil)
7595 (defun clearcase-increment-version (version-string)
7596 (let* ((branch (clearcase-vxpath-branch version-string))
7597 (number (clearcase-vxpath-version version-string))
7598 (new-number (1+ (string-to-number number))))
7599 (format "%s%d" branch new-number)))
7601 (defun clearcase-version-stamp ()
7603 (if (and clearcase-mode
7604 clearcase-version-stamp-active
7605 (file-exists-p buffer-file-name)
7606 (equal 'version (clearcase-fprop-mtype buffer-file-name)))
7607 (let ((latest-version (clearcase-fprop-predecessor-version buffer-file-name)))
7609 ;; Note: If the buffer happens to be folded, we may not find the place
7610 ;; to insert the version-stamp. Folding mode really needs to supply a
7611 ;; 'save-folded-excursion function to solve this one. We won't attempt
7612 ;; a cheaper hack here.
7617 (goto-char (point-min))
7618 (forward-line clearcase-version-stamp-line-limit)
7619 (let ((limit (point))
7622 (goto-char (point-min))
7623 (while (and (< (point) limit)
7624 (re-search-forward clearcase-version-stamp-begin-regexp
7627 (setq v-start (point))
7629 (let ((line-end (point)))
7631 (if (re-search-forward clearcase-version-stamp-end-regexp
7634 (setq v-end (match-beginning 0)))))
7636 (let ((new-version-stamp (clearcase-increment-version latest-version)))
7638 (delete-region v-start v-end)
7639 (insert-and-inherit new-version-stamp)))))))))
7641 (defun clearcase-hook-write-file-hook ()
7643 (clearcase-version-stamp)
7644 ;; Important to return nil so the files eventually gets written.
7650 ;;{{{ A kill-buffer hook
7652 (defun clearcase-hook-kill-buffer-hook ()
7653 (let ((filename (buffer-file-name)))
7655 ;; W3 has buffers in which 'buffer-file-name is bound to
7656 ;; a URL. Don't attempt to unstore their properties.
7658 (boundp 'buffer-file-truename)
7659 buffer-file-truename)
7660 (clearcase-fprop-unstore-properties filename))))
7664 ;;{{{ A kill-emacs-hook
7666 (defun clearcase-hook-kill-emacs-hook ()
7667 (clearcase-utl-clean-tempfiles))
7672 ;;{{{ Function: to replace toggle-read-only
7674 (defun clearcase-toggle-read-only (&optional arg)
7675 "Change read-only status of current buffer, perhaps via version control.
7676 If the buffer is visiting a ClearCase version, then check the file in or out.
7677 Otherwise, just change the read-only flag of the buffer. If called with an
7678 argument then just change the read-only flag even if visiting a ClearCase
7683 ((and (clearcase-fprop-mtype buffer-file-name)
7685 (file-writable-p buffer-file-name)
7689 ((clearcase-fprop-mtype buffer-file-name)
7690 (clearcase-next-action-current-buffer))
7693 (toggle-read-only))))
7696 ;;{{{ Functions: file-name-handlers
7698 ;;{{{ Start dynamic views automatically when paths to them are used
7700 ;; This handler starts views when viewroot-relative paths are dereferenced.
7702 ;; nyi: for now really only seems useful on Unix.
7704 (defun clearcase-viewroot-relative-file-name-handler (operation &rest args)
7706 (clearcase-when-debugging
7707 (if (fboundp 'clearcase-utl-syslog)
7708 (clearcase-utl-syslog "*clearcase-fh-trace*"
7709 (cons "clearcase-viewroot-relative-file-name-handler:"
7710 (cons operation args)))))
7712 ;; Inhibit the handler to avoid recursion.
7714 (let ((inhibit-file-name-handlers
7715 (cons 'clearcase-viewroot-relative-file-name-handler
7716 (and (eq inhibit-file-name-operation operation)
7717 inhibit-file-name-handlers)))
7718 (inhibit-file-name-operation operation))
7720 (let ((first-arg (car args)))
7721 ;; We don't always get called with a string.
7722 ;; e.g. one file operation is verify-visited-file-modtime, whose
7723 ;; first argument is a buffer.
7725 (if (stringp first-arg)
7727 ;; Now start the view if necessary
7730 (let* ((path (clearcase-path-remove-useless-viewtags first-arg))
7731 (viewtag (clearcase-vrpath-viewtag path))
7732 (default-directory (clearcase-path-remove-useless-viewtags default-directory)))
7734 (clearcase-viewtag-try-to-start-view viewtag))))))
7735 (apply operation args))))
7739 ;;{{{ Completion on viewtags
7741 ;; This handler provides completion for viewtags.
7743 (defun clearcase-viewtag-file-name-handler (operation &rest args)
7745 (clearcase-when-debugging
7746 (if (fboundp 'clearcase-utl-syslog)
7747 (clearcase-utl-syslog "*clearcase-fh-trace*"
7748 (cons "clearcase-viewtag-file-name-handler:"
7749 (cons operation args)))))
7752 ((eq operation 'file-name-completion)
7753 (save-match-data (apply 'clearcase-viewtag-completion args)))
7755 ((eq operation 'file-name-all-completions)
7756 (save-match-data (apply 'clearcase-viewtag-completions args)))
7759 (let ((inhibit-file-name-handlers
7760 (cons 'clearcase-viewtag-file-name-handler
7761 (and (eq inhibit-file-name-operation operation)
7762 inhibit-file-name-handlers)))
7763 (inhibit-file-name-operation operation))
7764 (apply operation args)))))
7766 (defun clearcase-viewtag-completion (file dir)
7767 (try-completion file (clearcase-viewtag-all-viewtag-dirs-obarray)))
7769 (defun clearcase-viewtag-completions (file dir)
7770 (let ((tags (all-completions file
7771 (clearcase-viewtag-all-viewtags-obarray))))
7773 (function (lambda (tag)
7779 ;;{{{ File name handler for version extended file names
7781 ;; For version extended pathnames there are two possible answers
7783 ;; file-name-directory
7784 ;; file-name-nondirectory
7786 ;; 1. that pertaining to the element path, e.g.
7787 ;; (file-name-directory "DIR/FILE@@/BRANCH/VERSION")
7789 ;; 2. that pertaining to the version path, e.g.
7790 ;; (file-name-directory "DIR/FILE@@/BRANCH/VERSION")
7791 ;; ==> "DIR/FILE@@/BRANCH/"
7793 ;; Often we'd like the former, but sometimes we'd like the latter, for example
7794 ;; inside clearcase-browse-vtree, where it calls dired. Within dired on Gnu
7795 ;; Emacs, it calls file-name-directory on the supplied pathname and in this
7796 ;; case we want the version (i.e. branch) path to be used.
7798 ;; How to get the behaviour we want ?
7803 ;; Define a variable clearcase-treat-branches-as-dirs, which modifies
7804 ;; the behaviour of clearcase-vxpath-file-name-handler to give answer (1).
7806 ;; Just before we invoke dired inside clearcase-browse-vtree, dynamically
7807 ;; bind clearcase-treat-branches-as-dirs to t. Also in the resulting Dired Mode
7808 ;; buffer, make clearcase-treat-branches-as-dirs buffer-local and set it.
7810 ;; Unfortunately this doesn't quite give us what we want. For example I often
7811 ;; invoke grep from a dired buffer on a branch-qua-directory to scan all the
7812 ;; version on that branch for a certain string. The grep-mode buffer has no
7813 ;; buffer-local binding for clearcase-treat-branches-as-dirs so the grep
7814 ;; command runs in "DIR/" instead of in "DIR/FILE@@/BRANCH/".
7819 ;; Modify the semantics of clearcase-vxpath-file-name-handler so that
7820 ;; if the filename given is a pathname to an existing branch-qua-directory
7821 ;; give answer 2, otherwise give answer 1.
7826 ;; Use the existence of a Dired Mode buffer on "DIR/FILE@@/BRANCH/" to
7827 ;; change the semantics of clearcase-vxpath-file-name-handler.
7829 ;; (A) is unsatisfactory and I'm not entirely happy with (B) nor (C) so for now
7830 ;; I'm going to disable this filename handler until I'm more convinced it is
7833 (defun clearcase-vxpath-file-name-handler (operation &rest args)
7834 (clearcase-when-debugging
7835 (if (fboundp 'clearcase-utl-syslog)
7836 (clearcase-utl-syslog "*clearcase-fh-trace*"
7837 (cons "clearcase-vxpath-file-name-handler:"
7838 (cons operation args)))))
7839 ;; Inhibit recursion:
7841 (let ((inhibit-file-name-handlers
7842 (cons 'clearcase-vxpath-file-name-handler
7843 (and (eq inhibit-file-name-operation operation)
7844 inhibit-file-name-handlers)))
7845 (inhibit-file-name-operation operation))
7847 (cond ((eq operation 'file-name-nondirectory)
7848 (file-name-nondirectory (clearcase-vxpath-element-part
7851 ((eq operation 'file-name-directory)
7852 (file-name-directory (clearcase-vxpath-element-part
7856 (apply operation args)))))
7861 ;;{{{ Advice: Disable VC in the MVFS
7863 ;; This handler ensures that VC doesn't attempt to operate inside the MVFS.
7864 ;; This stops it from futile searches for RCS directories and the like inside.
7865 ;; It prevents a certain amount of clutter in the MVFS' noent-cache.
7868 (defadvice vc-registered (around clearcase-interceptor disable compile)
7869 "Disable normal behavior if in a clearcase dynamic view.
7870 This is enabled/disabled by clearcase-integrate/clearcase-unintegrate."
7871 (if (clearcase-file-would-be-in-view-p (ad-get-arg 0))
7877 ;;{{{ Functions: integrate and un-integrate.
7879 ;; Prepare for XEmacs 21.5 behavior support.
7881 (defalias 'clearcase-install 'clearcase-integrate)
7882 (defalias 'clearcase-uninstall 'clearcase-unintegrate)
7885 (defun clearcase-integrate ()
7886 "Enable ClearCase integration"
7891 (clearcase-fprop-clear-all-properties)
7892 (clearcase-vprop-clear-all-properties)
7894 ;; 1. Install hooks.
7896 (add-hook 'find-file-hooks 'clearcase-hook-find-file-hook)
7897 (add-hook 'find-file-hooks 'clearcase-hook-vxpath-find-file-hook)
7898 (add-hook 'dired-mode-hook 'clearcase-hook-dired-mode-hook)
7899 (add-hook 'dired-after-readin-hook 'clearcase-hook-dired-after-readin-hook)
7900 (add-hook 'kill-buffer-hook 'clearcase-hook-kill-buffer-hook)
7901 (add-hook 'write-file-hooks 'clearcase-hook-write-file-hook)
7902 (add-hook 'kill-emacs-hook 'clearcase-hook-kill-emacs-hook)
7904 ;; 2. Install file-name handlers.
7906 ;; 2.1 Start views when //view/TAG or m:/TAG is referenced.
7908 (add-to-list 'file-name-handler-alist
7909 (cons clearcase-vrpath-regexp
7910 'clearcase-viewroot-relative-file-name-handler))
7912 ;; 2.2 Completion on viewtags.
7914 (if clearcase-complete-viewtags
7915 (add-to-list 'file-name-handler-alist
7916 (cons clearcase-viewtag-regexp
7917 'clearcase-viewtag-file-name-handler)))
7919 ;; 2.3 Turn off RCS/VCS/SCCS activity inside a ClearCase dynamic view.
7921 (if clearcase-suppress-vc-within-mvfs
7922 (when clearcase-suppress-vc-within-mvfs
7923 (ad-enable-advice 'vc-registered 'around 'clearcase-interceptor)
7924 (ad-activate 'vc-registered)))
7926 ;; Disabled for now. See comments above clearcase-vxpath-file-name-handler.
7928 ;; ;; 2.4 Add file name handler for version extended path names
7930 ;; (add-to-list 'file-name-handler-alist
7931 ;; (cons clearcase-vxpath-glue 'clearcase-vxpath-file-name-handler))
7935 (defun clearcase-unintegrate ()
7936 "Disable ClearCase integration"
7941 (clearcase-fprop-clear-all-properties)
7942 (clearcase-vprop-clear-all-properties)
7946 (remove-hook 'find-file-hooks 'clearcase-hook-find-file-hook)
7947 (remove-hook 'find-file-hooks 'clearcase-hook-vxpath-find-file-hook)
7948 (remove-hook 'dired-mode-hook 'clearcase-hook-dired-mode-hook)
7949 (remove-hook 'dired-after-readin-hook 'clearcase-hook-dired-after-readin-hook)
7950 (remove-hook 'kill-buffer-hook 'clearcase-hook-kill-buffer-hook)
7951 (remove-hook 'write-file-hooks 'clearcase-hook-write-file-hook)
7952 (remove-hook 'kill-emacs-hook 'clearcase-hook-kill-emacs-hook)
7954 ;; 2. Remove file-name handlers.
7956 (setq file-name-handler-alist
7957 (delete-if (function
7960 '(clearcase-viewroot-relative-file-name-handler
7961 clearcase-viewtag-file-name-handler
7962 clearcase-vxpath-file-name-handler))))
7963 file-name-handler-alist))
7965 ;; 3. Turn on RCS/VCS/SCCS activity everywhere.
7967 (ad-disable-advice 'vc-registered 'around 'clearcase-interceptor)
7968 (ad-activate 'vc-registered))
7972 ;; Here's where we really wire it all in:
7974 (defvar clearcase-cleartool-path nil)
7975 (defvar clearcase-clearcase-version-installed nil)
7976 (defvar clearcase-lt nil)
7977 (defvar clearcase-v3 nil)
7978 (defvar clearcase-v4 nil)
7979 (defvar clearcase-v5 nil)
7980 (defvar clearcase-v6 nil)
7981 (defvar clearcase-servers-online nil)
7982 (defvar clearcase-setview-root nil)
7983 (defvar clearcase-setview-viewtag)
7984 (defvar clearcase-setview-root nil)
7985 (defvar clearcase-setview-viewtag nil)
7988 ;; If the SHELL environment variable points to the wrong place,
7989 ;; call-process fails on Windows and this startup fails.
7990 ;; Check for this and unset the useless EV.
7992 (let ((shell-ev-value (getenv "SHELL")))
7993 (if clearcase-on-mswindows
7994 (if (stringp shell-ev-value)
7995 (if (not (executable-find shell-ev-value))
7996 (setenv "SHELL" nil)))))
7998 ;; Things have to be done here in a certain order.
8000 ;; 1. Make sure cleartool is on the shell search PATH.
8002 (if (setq clearcase-cleartool-path (clearcase-find-cleartool))
8004 ;; 2. Try to discover what version of ClearCase we have:
8006 (setq clearcase-clearcase-version-installed (clearcase-get-version-string))
8008 (not (null (string-match "ClearCase LT"
8009 clearcase-clearcase-version-installed))))
8011 (not (null (string-match "^ClearCase version 3"
8012 clearcase-clearcase-version-installed))))
8014 (not (null (string-match "^ClearCase version 4"
8015 clearcase-clearcase-version-installed))))
8017 (not (null (string-match "^ClearCase \\(LT \\)?version 2002.05"
8018 clearcase-clearcase-version-installed))))
8020 (not (null (string-match "^ClearCase \\(LT \\)?version 2003.06"
8021 clearcase-clearcase-version-installed))))
8023 ;; 3. Gather setview information:
8025 (if (setq clearcase-setview-root (if (not clearcase-on-mswindows)
8026 (getenv "CLEARCASE_ROOT")))
8027 (setq clearcase-setview-viewtag
8028 (file-name-nondirectory clearcase-setview-root)))
8030 ;; 4. Discover if the servers appear to be online.
8032 (setq clearcase-servers-online (clearcase-registry-server-online-p))
8034 (if clearcase-servers-online
8036 ;; 5. Everything seems in place to ensure that ClearCase mode will
8037 ;; operate correctly, so integrate now.
8040 (clearcase-integrate)
8041 ;; Schedule a fetching of the view properties when next idle.
8042 ;; This avoids awkward pauses after the user reaches for the
8043 ;; ClearCase menubar entry.
8045 (if clearcase-setview-viewtag
8046 (clearcase-vprop-schedule-work clearcase-setview-viewtag)))))))
8048 (if (not clearcase-servers-online)
8049 (message "ClearCase apparently not online. ClearCase/Emacs integration not installed."))
8053 (provide 'clearcase)
8055 ;;; clearcase.el ends here
8059 ;; clearcase-version-stamp-active: t