diff --git a/init.el b/init.el index e61b757..e488a42 100644 --- a/init.el +++ b/init.el @@ -759,7 +759,6 @@ (load "round-number-to-decimals.el") (load "transpose-windows.el") (load "zim.el") -(load "clearcase.el") (load "enclose-string.el") (load "buf-manipulation.el") (load "text-manip") diff --git a/lisp/clearcase.el b/lisp/clearcase.el deleted file mode 100644 index 542ef8b..0000000 --- a/lisp/clearcase.el +++ /dev/null @@ -1,7968 +0,0 @@ -;;; clearcase.el --- ClearCase/Emacs integration. - -;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2006, 2007 Kevin Esler - -;; Author: Kevin Esler -;; Maintainer: Kevin Esler -;; Keywords: clearcase tools -;; Web home: http://members.verizon.net/~kevin.a.esler/EmacsClearCase - -;; This file is not part of GNU Emacs. -;; -;; This program is free software; you can redistribute it and/or modify it under -;; the terms of the GNU General Public License as published by the Free Software -;; Foundation; either version 2, or (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, but WITHOUT -;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more -;; details. - -;; You should have received a copy of the GNU General Public License along with -;; GNU Emacs; see the file COPYING. If not, write to the Free Software -;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -;;{{{ Introduction - -;; This is a ClearCase/Emacs integration. -;; -;; -;; How to use -;; ========== -;; -;; 0. Make sure you're using Gnu Emacs-20.4 or later or a recent XEmacs. -;; In general it seems to work better in Gnu Emacs than in XEmacs, -;; although many XEmacs users have no problems at all with it. -;; -;; 1. Make sure that you DON'T load old versions of vc-hooks.el which contain -;; incompatible versions of the tq package (functions tq-enqueue and -;; friends). In particular, Bill Sommerfeld's VC/CC integration has this -;; problem. -;; -;; 2. Copy the files (or at least the clearcase.elc file) to a directory -;; on your emacs-load-path. -;; -;; 3. Insert this in your emacs startup file: (load "clearcase") -;; -;; When you begin editing in any view-context, a ClearCase menu will appear -;; and ClearCase Minor Mode will be activated for you. -;; -;; Summary of features -;; =================== -;; -;; Keybindings compatible with Emacs' VC (where it makes sense) -;; Richer interface than VC -;; Works on NT and Unix -;; Context sensitive menu (Emacs knows the ClearCase-status of files) -;; Snapshot view support: update, version comparisons -;; Can use Emacs Ediff for version comparison display -;; Dired Mode: -;; - en masse checkin/out etc -;; - enhanced display -;; - browse version tree -;; Completion of viewnames, version strings -;; Auto starting of views referenced as /view/TAG/.. (or \\view\TAG\...) -;; Emacs for editing comments, config specs -;; Standard ClearCase GUI tools launchable from Emacs menu -;; - version tree browser -;; - project browser -;; - UCM deliver -;; - UCM rebase -;; Operations directly available from Emacs menu/keymap: -;; create-activity -;; set-activity -;; mkelem, -;; checkout -;; checkin, -;; unco, -;; describe -;; list history -;; edit config spec -;; mkbrtype -;; snapshot view update: file, directory, view -;; version comparisons using ediff, diff or GUI -;; find checkouts -;; annotate version -;; et al. -;; -;; Acknowledgements -;; ================ -;; -;; The help of the following is gratefully acknowledged: -;; -;; XEmacs support and other bugfixes: -;; -;; Rod Whitby -;; Adrian Aichner -;; -;; This was a result of examining earlier versions of VC and VC/ClearCase -;; integrations and borrowing freely therefrom. Accordingly, the following -;; are ackowledged as contributors: -;; -;; VC/ClearCase integration authors: -;; -;; Bill Sommerfeld -;; Rod Whitby -;; Andrew Markebo -;; Andy Eskilsson -;; Paul Smith -;; John Kohl -;; Chris Felaco -;; -;; VC authors: -;; -;; Eric S. Raymond -;; Andre Spiegel -;; Sebastian Kremer -;; Richard Stallman -;; Per Cederqvist -;; ttn@netcom.com -;; Andre Spiegel -;; Jonathan Stigelman -;; Steve Baur -;; -;; Other Contributors: -;; -;; Alastair Rankine -;; Andrew Maguire -;; Barnaby Dalton -;; Christian Savard -;; David O'Shea -;; Dee Zsombor -;; Gabor Zoka -;; Jason Rumney -;; Jeff Phillips -;; Justin Vallon -;; Mark Collins -;; Patrik Madison -;; Ram Bhamidipaty -;; Reinhard Hahn -;; Richard Kim -;; Richard Y. Kim -;; Simon Graham -;; Stephen Leake -;; Steven E. Harris -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;}}} - -;;{{{ Version info - -(defconst clearcase-version-stamp "ClearCase-version: ") -(defconst clearcase-version (substring clearcase-version-stamp 19)) - -(defun clearcase-maintainer-address () - ;; Avoid spam. - ;; - (concat "kevin.esler.1989" - "@" - "alum.bu.edu")) - -(defun clearcase-submit-bug-report () - "Submit via mail a bug report on ClearCase Mode" - (interactive) - (and (y-or-n-p "Do you really want to submit a report on ClearCase Mode ? ") - (reporter-submit-bug-report - (clearcase-maintainer-address) - (concat "clearcase.el " clearcase-version) - '( - system-type - system-configuration - emacs-version - clearcase-clearcase-version-installed - clearcase-cleartool-path - clearcase-lt - clearcase-v3 - clearcase-v4 - clearcase-v5 - clearcase-v6 - clearcase-servers-online - clearcase-disable-tq - clearcase-on-cygwin - clearcase-setview-root - clearcase-suppress-vc-within-mvfs - shell-file-name - w32-quote-process-args - )))) - -;;}}} - -;;{{{ Macros - -(defmacro clearcase-when-debugging (&rest forms) - (list 'if 'clearcase-debug (cons 'progn forms))) - -(defmacro clearcase-with-tempfile (filename-var &rest forms) - `(let ((,filename-var (clearcase-utl-tempfile-name))) - (unwind-protect - ,@forms - - ;; Cleanup. - ;; - (if (file-exists-p ,filename-var) - (delete-file ,filename-var))))) - -;;}}} - -;;{{{ Portability - -(defvar clearcase-xemacs-p (string-match "XEmacs" emacs-version)) - -(defvar clearcase-on-mswindows (memq system-type - '(windows-nt ms-windows cygwin cygwin32))) - -(defvar clearcase-on-cygwin (memq system-type '(cygwin cygwin32))) - -(defvar clearcase-sink-file-name - (cond - (clearcase-on-cygwin "/dev/null") - (clearcase-on-mswindows "NUL") - (t "/dev/null"))) - -(defun clearcase-view-mode-quit (buf) - "Exit from View mode, restoring the previous window configuration." - (progn - (cond ((frame-property (selected-frame) 'clearcase-view-window-config) - (set-window-configuration - (frame-property (selected-frame) 'clearcase-view-window-config)) - (set-frame-property (selected-frame) 'clearcase-view-window-config nil)) - ((not (one-window-p)) - (delete-window))) - (kill-buffer buf))) - -(defun clearcase-view-mode (arg &optional camefrom) - (if clearcase-xemacs-p - (let* ((winconfig (current-window-configuration)) - (was-one-window (one-window-p)) - (buffer-name (buffer-name (current-buffer))) - (clearcase-view-not-visible - (not (and (windows-of-buffer buffer-name) ;shortcut - (memq (selected-frame) - (mapcar 'window-frame - (windows-of-buffer buffer-name))))))) - (when clearcase-view-not-visible - (set-frame-property (selected-frame) - 'clearcase-view-window-config winconfig)) - (view-mode camefrom 'clearcase-view-mode-quit) - (setq buffer-read-only nil)) - (view-mode arg))) - -(defun clearcase-port-view-buffer-other-window (buffer) - (if clearcase-xemacs-p - (switch-to-buffer-other-window buffer) - (view-buffer-other-window buffer nil 'kill-buffer))) - -(defun clearcase-dired-sort-by-date () - (if (fboundp 'dired-sort-by-date) - (dired-sort-by-date))) - -;; Copied from emacs-20 -;; -(if (not (fboundp 'subst-char-in-string)) - (defun subst-char-in-string (fromchar tochar string &optional inplace) - "Replace FROMCHAR with TOCHAR in STRING each time it occurs. -Unless optional argument INPLACE is non-nil, return a new string." - (let ((i (length string)) - (newstr (if inplace string (copy-sequence string)))) - (while (> i 0) - (setq i (1- i)) - (if (eq (aref newstr i) fromchar) - (aset newstr i tochar))) - newstr))) - -;;}}} - -;;{{{ Require calls - -;; nyi: we also use these at the moment: -;; -view -;; -ediff -;; -view -;; -dired-sort - -(require 'cl) -(require 'comint) -(require 'dired) -(require 'easymenu) -(require 'executable) -(require 'reporter) -(require 'ring) -(or clearcase-xemacs-p - (require 'timer)) - -;; NT Emacs - doesn't use tq. -;; -(if (not clearcase-on-mswindows) - (require 'tq)) - -;;}}} - -;;{{{ Debugging facilities - -;; Setting this to true will enable some debug code. -;; -(defvar clearcase-debug nil) - -(defun clearcase-trace (string) - (clearcase-when-debugging - (let ((trace-buf (get-buffer "*clearcase-trace*"))) - (if trace-buf - (save-excursion - (set-buffer trace-buf) - (goto-char (point-max)) - (insert string "\n")))))) - -(defun clearcase-enable-tracing () - (interactive) - (setq clearcase-debug t) - (get-buffer-create "*clearcase-trace*")) - -(defun clearcase-disable-tracing () - (interactive) - (setq clearcase-debug nil)) - -(defun clearcase-dump () - (interactive) - (clearcase-utl-populate-and-view-buffer - "*clearcase-dump*" - nil - (function (lambda () - (clearcase-fprop-dump-to-current-buffer) - (clearcase-vprop-dump-to-current-buffer))))) - -(defun clearcase-flush-caches () - (interactive) - (clearcase-fprop-clear-all-properties) - (clearcase-vprop-clear-all-properties)) - -;;}}} - -;;{{{ Customizable variables - -(eval-and-compile - (condition-case nil - (require 'custom) - (error nil)) - (if (and (featurep 'custom) - (fboundp 'custom-declare-variable)) - nil ;; We've got what we needed - ;; We have the old custom-library, hack around it! - (defmacro defgroup (&rest args) - nil) - (defmacro defcustom (var value doc &rest args) - (` (defvar (, var) (, value) (, doc)))) - (defmacro defface (face value doc &rest stuff) - `(make-face ,face)) - (defmacro custom-declare-variable (symbol value doc &rest args) - (list 'defvar (eval symbol) value doc)))) - -(defgroup clearcase () "ClearCase Options" :group 'tools :prefix "clearcase") - -(defcustom clearcase-keep-uncheckouts t - "When true, the contents of an undone checkout will be kept in a file -with a \".keep\" suffix. Otherwise it will be removed." - :group 'clearcase - :type 'boolean) - -(defcustom clearcase-keep-unhijacks t - "When true, the contents of an undone hijack will be kept in a file -with a \".keep\" suffix. Otherwise it will be removed." - :group 'clearcase - :type 'boolean) - -;; nyi: We could also allow a value of 'prompt here -;; -(defcustom clearcase-set-to-new-activity t - "*If this variable is non-nil when a new activity is created, that activity -will be set as the current activity for the view, otherwise no change is made -to the view's current activity setting." - :group 'clearcase - :type 'boolean) - -(defcustom clearcase-prompt-for-activity-names t - "*If this variable is non-nil the user will be prompted for activity names. -Otherwise, activity names will be generated automatically and will typically -have the form \"activity011112.155233\". If the name entered is empty sucn an -internal name will also be generated." - :group 'clearcase - :type 'boolean) - -(defcustom clearcase-make-backup-files nil - "*If non-nil, backups of ClearCase files are made as with other files. -If nil (the default), files under ClearCase control don't get backups." - :group 'clearcase - :type 'boolean) - -(defcustom clearcase-complete-viewtags t - "*If non-nil, completion on viewtags is enabled. For sites with thousands of view -this should be set to nil." - :group 'clearcase - :type 'boolean) - -(defcustom clearcase-minimise-menus nil - "*If non-nil, menus will hide rather than grey-out inapplicable choices." - :group 'clearcase - :type 'boolean) - -(defcustom clearcase-auto-dired-mode t - "*If non-nil, automatically enter `clearcase-dired-mode' in dired-mode -for directories in ClearCase." - :group 'clearcase - :type 'boolean) - -(defcustom clearcase-dired-highlight t - "If non-nil, highlight reserved files in clearcase-dired buffers." - :group 'clearcase - :type 'boolean) - -(defcustom clearcase-dired-show-view t - "If non-nil, show the view tag in dired buffers." - :group 'clearcase - :type 'boolean) - -(defcustom clearcase-verify-pre-mkelem-dir-checkout nil - "*If non-nil, prompt before checking out the containing directory -before creating a new ClearCase element." - :group 'clearcase - :type 'boolean) - -(defcustom clearcase-diff-on-checkin nil - "Display diff on checkin to help you compose the checkin comment." - :group 'clearcase - :type 'boolean) - -;; General customization - -(defcustom clearcase-suppress-confirm nil - "If non-nil, treat user as expert; suppress yes-no prompts on some things." - :group 'clearcase - :type 'boolean) - -(defcustom clearcase-initial-mkelem-comment nil - "Prompt for initial comment when an element is created." - :group 'clearcase - :type 'boolean) - -(defcustom clearcase-command-messages nil - "Display run messages from back-end commands." - :group 'clearcase - :type 'boolean) - -(defcustom clearcase-checkin-arguments - ;; For backwards compatibility with old name for this variable: - ;; - (if (and (boundp 'clearcase-checkin-switches) - (not (null clearcase-checkin-switches))) - (list clearcase-checkin-switches) - nil) - "A list of extra arguments passed to the checkin command." - :group 'clearcase - :type '(repeat (string :tag "Argument"))) - -(defcustom clearcase-checkin-on-mkelem nil - "If t, file will be checked-in when first created as an element." - :group 'clearcase - :type 'boolean) - -(defcustom clearcase-suppress-checkout-comments nil - "Suppress prompts for checkout comments for those version control -systems which use them." - :group 'clearcase - :type 'boolean) - -(defcustom clearcase-checkout-arguments - ;; For backwards compatibility with old name for this variable: - ;; - (if (and (boundp 'clearcase-checkout-arguments) - (not (null clearcase-checkout-arguments))) - (list clearcase-checkout-arguments) - nil) - "A list of extra arguments passed to the checkout command." - :group 'clearcase - :type '(repeat (string :tag "Argument"))) - -(defcustom clearcase-directory-exclusion-list '("lost+found") - "Directory names ignored by functions that recursively walk file trees." - :group 'clearcase - :type '(repeat (string :tag "Subdirectory"))) - -(defcustom clearcase-use-normal-diff nil - "If non-nil, use normal diff instead of cleardiff." - :group 'clearcase - :type 'boolean) - -(defcustom clearcase-normal-diff-program "diff" - "*Program to use for generating the differential of the two files -when `clearcase-use-normal-diff' is t." - :group 'clearcase - :type 'string) - -(defcustom clearcase-normal-diff-arguments - (if (and (boundp 'clearcase-normal-diff-switches) - (not (null clearcase-normal-diff-switches))) - (list clearcase-normal-diff-switches) - (list "-u")) - "A list of extra arguments passed to `clearcase-normal-diff-program' -when `clearcase-use-normal-diff' is t. Usage of the -u switch is -recommended to produce unified diffs, when your -`clearcase-normal-diff-program' supports it." - :group 'clearcase - :type '(repeat (string :tag "Argument"))) - -(defcustom clearcase-vxpath-glue "@@" - "The string used to construct version-extended pathnames." - :group 'clearcase - :type 'string) - -(defcustom clearcase-viewroot (if clearcase-on-mswindows - "//view" - "/view") - "The ClearCase viewroot directory." - :group 'clearcase - :type 'file) - -(defcustom clearcase-viewroot-drive "m:" - "The ClearCase viewroot drive letter for Windows." - :group 'clearcase - :type 'string) - -(defcustom clearcase-suppress-vc-within-mvfs t - "Suppresses VC activity within the MVFS." - :group 'clearcase - :type 'boolean) - -(defcustom clearcase-hide-rebase-activities t - "Hide rebase activities from activity selection list." - :group 'clearcase - :type 'boolean) - -(defcustom clearcase-rebase-id-regexp "^rebase\\." - "The regexp used to detect rebase actvities." - :group 'clearcase - :type 'string) - -;;}}} - -;;{{{ Global variables - -(if (not (boundp 'directory-sep-char)) - (setq directory-sep-char ?/)) - -;; Initialize clearcase-pname-sep-regexp according to -;; directory-sep-char. -(defvar clearcase-pname-sep-regexp - (format "[%s/]" - (char-to-string directory-sep-char))) - -(defvar clearcase-non-pname-sep-regexp - (format "[^%s/]" - (char-to-string directory-sep-char))) - -;; Matches any viewtag (without the trailing "/"). -;; -(defvar clearcase-viewtag-regexp - (concat "^" - clearcase-viewroot - clearcase-pname-sep-regexp - "\\(" - clearcase-non-pname-sep-regexp "*" - "\\)" - "$" - )) - -;; Matches ANY viewroot-relative path -;; -(defvar clearcase-vrpath-regexp - (concat "^" - clearcase-viewroot - clearcase-pname-sep-regexp - "\\(" - clearcase-non-pname-sep-regexp "*" - "\\)" - )) - -;;}}} - -;;{{{ Minor Mode: ClearCase - -;; For ClearCase Minor Mode -;; -(defvar clearcase-mode nil) -(set-default 'clearcase-mode nil) -(make-variable-buffer-local 'clearcase-mode) -(put 'clearcase-mode 'permanent-local t) - -;; Tell Emacs about this new kind of minor mode -;; -(if (not (assoc 'clearcase-mode minor-mode-alist)) - (setq minor-mode-alist (cons '(clearcase-mode clearcase-mode) - minor-mode-alist))) - -;; For now we override the bindings for VC Minor Mode with ClearCase Minor Mode -;; bindings. -;; -(defvar clearcase-mode-map (make-sparse-keymap)) -(defvar clearcase-prefix-map (make-sparse-keymap)) -(define-key clearcase-mode-map "\C-xv" clearcase-prefix-map) -(define-key clearcase-mode-map "\C-x\C-q" 'clearcase-toggle-read-only) - -(define-key clearcase-prefix-map "b" 'clearcase-browse-vtree-current-buffer) -(define-key clearcase-prefix-map "c" 'clearcase-uncheckout-current-buffer) -(define-key clearcase-prefix-map "e" 'clearcase-edcs-edit) -(define-key clearcase-prefix-map "g" 'clearcase-annotate-current-buffer) -(define-key clearcase-prefix-map "i" 'clearcase-mkelem-current-buffer) -(define-key clearcase-prefix-map "l" 'clearcase-list-history-current-buffer) -(define-key clearcase-prefix-map "m" 'clearcase-mkbrtype) -(define-key clearcase-prefix-map "u" 'clearcase-uncheckout-current-buffer) -(define-key clearcase-prefix-map "v" 'clearcase-next-action-current-buffer) -(define-key clearcase-prefix-map "w" 'clearcase-what-rule-current-buffer) -(define-key clearcase-prefix-map "=" 'clearcase-diff-pred-current-buffer) -(define-key clearcase-prefix-map "?" 'clearcase-describe-current-buffer) -(define-key clearcase-prefix-map "~" 'clearcase-version-other-window) - -;; To avoid confusion, we prevent VC Mode from being active at all by -;; undefining its keybindings for which ClearCase Mode doesn't yet have an -;; analogue. -;; -(define-key clearcase-prefix-map "a" 'undefined) ;; vc-update-change-log -(define-key clearcase-prefix-map "d" 'undefined) ;; vc-directory -(define-key clearcase-prefix-map "h" 'undefined) ;; vc-insert-headers -(define-key clearcase-prefix-map "m" 'undefined) ;; vc-merge -(define-key clearcase-prefix-map "r" 'undefined) ;; vc-retrieve-snapshot -(define-key clearcase-prefix-map "s" 'undefined) ;; vc-create-snapshot -(define-key clearcase-prefix-map "t" 'undefined) ;; vc-dired-toggle-terse-mode - -;; Associate the map and the minor mode -;; -(or (not (boundp 'minor-mode-map-alist)) - (assq 'clearcase-mode (symbol-value 'minor-mode-map-alist)) - (setq minor-mode-map-alist - (cons (cons 'clearcase-mode clearcase-mode-map) - minor-mode-map-alist))) - -(defun clearcase-mode (&optional arg) - "ClearCase Minor Mode" - - (interactive "P") - - ;; Behave like a proper minor-mode. - ;; - (setq clearcase-mode - (if (interactive-p) - (if (null arg) - (not clearcase-mode) - - ;; Check if the numeric arg is positive. - ;; - (> (prefix-numeric-value arg) 0)) - - ;; else - ;; Use the car if it's a list. - ;; - (if (consp arg) - (setq arg (car arg))) - (if (symbolp arg) - (if (null arg) - (not clearcase-mode) ;; toggle mode switch - (not (eq '- arg))) ;; True if symbol is not '- - - ;; else - ;; assume it's a number and check that. - ;; - (> arg 0)))) - - (if clearcase-mode - (easy-menu-add clearcase-menu 'clearcase-mode-map)) - ) - -;;}}} - -;;{{{ Minor Mode: ClearCase Dired - -;;{{{ Reformatting the Dired buffer - -;; Create a face for highlighting checked out files in clearcase-dired. -;; -(if (not (memq 'clearcase-dired-checkedout-face (face-list))) - (progn - (make-face 'clearcase-dired-checkedout-face) - (set-face-foreground 'clearcase-dired-checkedout-face "red"))) - -(defun clearcase-dired-insert-viewtag () - (save-excursion - (progn - (goto-char (point-min)) - - ;; Only do this if the buffer is not currently narrowed - ;; - (if (= 1 (point)) - (let ((viewtag (clearcase-fprop-viewtag (file-truename default-directory)))) - (if viewtag - (progn - (forward-line 1) - (let ((buffer-read-only nil)) - (insert (format " [ClearCase View: %s]\n" viewtag)))))))))) - -(defun clearcase-dired-reformat-buffer () - "Reformats the current dired buffer." - (let* ((checkout-list nil) - (modified-file-info nil) - (hijack-list nil) - (directory default-directory) - subdir - fullpath) - - ;; Iterate over each line in the buffer. - ;; - ;; Important notes: - ;; 1. In general, a Dired buffer can contain listings for several - ;; directories. We pass though from top to bottom and adjust - ;; subdir as we go. - ;; 2. Since this is called from dired-after-reading-hook, it can get - ;; called on a single-line buffer. In this case there is no subdir, - ;; and no checkout-list. We need to call clearcase-fprop-checked-out - ;; to test for a checkout. - ;; - (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (cond - - ;; Case 1: Look for directory markers - ;; - ((setq subdir (dired-get-subdir)) - - ;; We're at a subdirectory line in the dired buffer. - ;; Go and list all checkouts and hijacks in this subdirectory. - ;; - (setq modified-file-info (clearcase-dired-list-modified-files subdir)) - (setq checkout-list (nth 0 modified-file-info)) - (setq hijack-list (nth 1 modified-file-info)) - - ;; If no checkouts are found, we don't need to check each file, and - ;; it's very slow. The checkout-list should contain something so it - ;; doesn't attempt to do this. - ;; - (if (null checkout-list) - (setq checkout-list '(nil))) - (if (null hijack-list) - (setq hijack-list '(nil))) - (message "Reformatting %s..." subdir)) - - ;; Case 2: Look for files (the safest way to get the filename). - ;; - ((setq fullpath (dired-get-filename nil t)) - - ;; Expand it to get rid of . and .. entries. - ;; - (setq fullpath (expand-file-name fullpath)) - - (setq fullpath (clearcase-path-canonicalise-slashes fullpath)) - - ;; Only modify directory listings of the correct format. - ;; We replace the GID field with a checkout indicator. - ;; - (if (looking-at - ;; (1) (2) (3) (4) - ;; -rw-rw-rw- 1 esler 5 28 Feb 2 16:02 foo.el - "..\\([drwxlts-]+ \\) *\\([0-9]+\\) \\([^ ]+\\) *\\([^ ]+ *\\) +[0-9]+\\( [^ 0-9]+ [0-9 ][0-9] .*\\)") - - (let* ((replacement-begin (match-beginning 4)) - (replacement-end (match-end 4)) - - (replacement-length (- replacement-end replacement-begin)) - (checkout-replacement-text (format "CHECKOUT")) - (hijack-replacement-text (format "HIJACK")) - (is-checkout (if checkout-list - (member fullpath checkout-list) - (clearcase-fprop-checked-out fullpath))) - (is-hijack (if hijack-list - (member fullpath hijack-list) - (clearcase-fprop-hijacked fullpath)))) - - ;; Highlight the line if the file is checked-out. - ;; - (if is-checkout - (progn - ;; Replace the GID field with CHECKOUT. - ;; - (let ((buffer-read-only nil)) - - ;; Pad with replacement text with trailing spaces if necessary. - ;; - (if (>= replacement-length (length checkout-replacement-text)) - (setq checkout-replacement-text - (concat checkout-replacement-text - (make-string (- replacement-length (length checkout-replacement-text)) - 32)))) - (goto-char replacement-begin) - (delete-char replacement-length) - (insert (substring checkout-replacement-text 0 replacement-length))) - - ;; Highlight the checked out files. - ;; - (if (fboundp 'put-text-property) - (let ((buffer-read-only nil)) - (put-text-property replacement-begin replacement-end - 'face 'clearcase-dired-checkedout-face))) - ) - ) - - (if is-hijack - (progn - ;; Replace the GID field with CHECKOUT. - ;; - (let ((buffer-read-only nil)) - - ;; Pad with replacement text with trailing spaces if necessary. - ;; - (if (>= replacement-length (length hijack-replacement-text)) - (setq hijack-replacement-text - (concat hijack-replacement-text - (make-string (- replacement-length (length hijack-replacement-text)) - 32)))) - (goto-char replacement-begin) - (delete-char replacement-length) - (insert (substring hijack-replacement-text 0 replacement-length))) - - ;; Highlight the checked out files. - ;; - (if (fboundp 'put-text-property) - (let ((buffer-read-only nil)) - (put-text-property replacement-begin replacement-end - 'face 'clearcase-dired-checkedout-face))) - ) - ) - - )))) - (forward-line 1)))) - (message "Reformatting...Done")) - - -(defun clearcase-path-follow-if-vob-slink (path) - (if (clearcase-fprop-file-is-vob-slink-p path) - - ;; It's a slink so follow it. - ;; - (let ((slink-text (clearcase-fprop-vob-slink-text path))) - (if (file-name-absolute-p slink-text) - slink-text - (concat (file-name-directory path) slink-text))) - - ;; Not an slink. - ;; - path)) - -;;{{{ Searching for modified files - -;;{{{ Old code - -;; (defun clearcase-dired-list-checkouts (directory) -;; "Returns a list of files checked-out to the current view in DIRECTORY." - -;; ;; Don't bother looking for checkouts in -;; ;; - a history-mode branch-qua-directory -;; ;; - a view-private directory -;; ;; -;; ;; NYI: For now don't run lsco in root of a snapshot because it gives errors. -;; ;; We need to make this smarter. -;; ;; -;; ;; NYI: For a pathname which is a slink to a dir, despite the fact that -;; ;; clearcase-fprop-file-is-version-p returns true, lsco fails on it, -;; ;; with "not an element". Sheesh, surely lsco ought to follow links ? -;; ;; Solution: catch the error and check if the dir is a slink then follow -;; ;; the link and retry the lsco on the target. -;; ;; -;; ;; For now just ignore the error. -;; ;; -;; (if (and (not (clearcase-vxpath-p directory)) -;; (not (eq 'view-private-object (clearcase-fprop-mtype directory))) -;; (clearcase-fprop-file-is-version-p directory)) - - -;; (let* ((ignore (message "Listing ClearCase checkouts...")) - -;; (true-dir-path (file-truename directory)) - -;; ;; Give the directory as an argument so all names will be -;; ;; fullpaths. For some reason ClearCase adds an extra slash if you -;; ;; leave the trailing slash on the directory, so we need to remove -;; ;; it. -;; ;; -;; (native-dir-path (clearcase-path-native (directory-file-name true-dir-path))) - -;; (followed-dir-path (clearcase-path-follow-if-vob-slink native-dir-path)) - -;; ;; Form the command: -;; ;; -;; (cmd (list -;; "lsco" "-cview" "-fmt" -;; (if clearcase-on-mswindows -;; "%n\\n" -;; "'%n\\n'") - -;; followed-dir-path)) - -;; ;; Capture the output: -;; ;; -;; (string (clearcase-path-canonicalise-slashes -;; (apply 'clearcase-ct-cleartool-cmd cmd))) - -;; ;; Split the output at the newlines: -;; ;; -;; (checkout-list (clearcase-utl-split-string-at-char string ?\n))) - -;; ;; Add entries for "." and ".." if they're checked-out. -;; ;; -;; (let* ((entry ".") -;; (path (expand-file-name (concat (file-name-as-directory true-dir-path) -;; entry)))) -;; (if (clearcase-fprop-checked-out path) -;; (setq checkout-list (cons path checkout-list)))) -;; (let* ((entry "..") -;; (path (expand-file-name (concat (file-name-as-directory true-dir-path) -;; entry)))) -;; (if (clearcase-fprop-checked-out path) -;; (setq checkout-list (cons path checkout-list)))) - -;; ;; If DIRECTORY is a vob-slink, checkout list will contain pathnames -;; ;; relative to the vob-slink target rather than to DIRECTORY. Convert -;; ;; them back here. We're making it appear that lsco works on -;; ;; slinks-to-dirs. -;; ;; -;; (if (clearcase-fprop-file-is-vob-slink-p true-dir-path) -;; (let ((re (regexp-quote (file-name-as-directory followed-dir-path)))) -;; (setq checkout-list -;; (mapcar -;; (function -;; (lambda (path) -;; (replace-regexp-in-string re true-dir-path path))) -;; checkout-list)))) - -;; (message "Listing ClearCase checkouts...done") - -;; ;; Return the result. -;; ;; -;; checkout-list) -;; )) - -;; ;; I had believed that this implementation below OUGHT to be faster, having -;; ;; read the code in "ct+lsco". It seemed that "lsco -cview" hit the VOB and -;; ;; listed all checkouts on all elements in the directory, and then filtered by -;; ;; view. I thought it would probably be quicker to run "ct ls -vob_only" and -;; ;; keep the lines that have "[eclipsed by checkout]". However this code -;; ;; actually seemed to run slower. Leave the code here for now so I can test -;; ;; further. -;; ;; -;; (defun clearcase-dired-list-checkouts-experimental (directory) -;; "Returns a list of files checked-out to the current view in DIRECTORY." - -;; ;; Don't bother looking for checkouts in a history-mode listing -;; ;; nor in view-private directories. -;; ;; -;; (if (and (not (clearcase-vxpath-p directory)) -;; (not (eq 'view-private-object (clearcase-fprop-mtype directory)))) - -;; (let* ((ignore (message "Listing ClearCase checkouts...")) - -;; (true-directory (file-truename directory)) - -;; ;; Move temporarily to the directory: -;; ;; -;; (default-directory true-directory) - -;; ;; Form the command: -;; ;; -;; (cmd (list "ls" "-vob_only")) - -;; ;; Capture the output: -;; ;; -;; (string (clearcase-path-canonicalise-slashes -;; (apply 'clearcase-ct-cleartool-cmd cmd))) - -;; ;; Split the output at the newlines: -;; ;; -;; (line-list (clearcase-utl-split-string-at-char string ?\n)) - -;; (checkout-list nil)) - -;; ;; Look for lines of the form: -;; ;; FILENAME@@ [eclipsed by checkout] -;; ;; -;; (mapcar (function -;; (lambda (line) -;; (if (string-match "^\\([^ @]+\\)@@ +\\[eclipsed by checkout\\].*" line) -;; (setq checkout-list (cons (concat -;; ;; Add back directory name to get -;; ;; full pathname. -;; ;; -;; default-directory -;; (substring line -;; (match-beginning 1) -;; (match-end 1))) -;; checkout-list))))) -;; line-list) - -;; ;; Add entries for "." and ".." if they're checked-out. -;; ;; -;; (let* ((entry ".") -;; (path (expand-file-name (concat true-directory entry)))) -;; (if (clearcase-fprop-checked-out path) -;; (setq checkout-list (cons path checkout-list)))) -;; (let* ((entry "..") -;; (path (expand-file-name (concat true-directory entry)))) -;; (if (clearcase-fprop-checked-out path) -;; (setq checkout-list (cons path checkout-list)))) - -;; (message "Listing ClearCase checkouts...done") - -;; ;; Return the result. -;; ;; -;; checkout-list))) - -;; (defun clearcase-dired-list-hijacks (directory) -;; "Returns a list of files hijacked to the current view in DIRECTORY." - -;; ;; Don't bother looking for hijacks in; -;; ;; - a history-mode listing -;; ;; - a in view-private directory -;; ;; - a dynamic view -;; ;; -;; (let* ((true-directory (file-truename directory)) -;; (viewtag (clearcase-fprop-viewtag true-directory))) - -;; (if (and viewtag -;; (not (clearcase-vxpath-p directory)) -;; (not (eq 'view-private-object (clearcase-fprop-mtype directory))) -;; (clearcase-file-would-be-in-snapshot-p true-directory)) - -;; (let* ((ignore (message "Listing ClearCase hijacks...")) - -;; (true-directory (file-truename directory)) - -;; ;; Form the command: -;; ;; -;; (cmd (list -;; "ls" - -;; ;; Give the directory as an argument so all names will be -;; ;; fullpaths. For some reason ClearCase adds an extra slash -;; ;; if you leave the trailing slash on the directory, so we -;; ;; need to remove it. -;; ;; -;; (clearcase-path-native (directory-file-name true-directory)))) - -;; ;; Capture the output: -;; ;; -;; (string (clearcase-path-canonicalise-slashes -;; (apply 'clearcase-ct-cleartool-cmd cmd))) - -;; ;; Split the output at the newlines: -;; ;; -;; (line-list (clearcase-utl-split-string-at-char string ?\n)) - -;; (hijack-list nil)) - -;; (mapcar (function -;; (lambda (line) -;; (if (string-match "^\\([^ @]+\\)@@[^ ]+ \\[hijacked\\].*" line) -;; (setq hijack-list (cons (substring line -;; (match-beginning 1) -;; (match-end 1)) -;; hijack-list))))) -;; line-list) - -;; (message "Listing ClearCase hijacks...done") - -;; ;; Return the result. -;; ;; -;; hijack-list)))) - -;;}}} - -(defun clearcase-dired-list-modified-files (directory) - "Returns a pair of lists of files (checkouts . hijacks) to the current view in DIRECTORY." - - ;; Don't bother looking for hijacks in; - ;; - a history-mode listing - ;; - a in view-private directory - ;; - a dynamic view - ;; - (let* ((true-directory (file-truename directory)) - (viewtag (clearcase-fprop-viewtag true-directory)) - (snapshot (clearcase-file-would-be-in-snapshot-p true-directory)) - (result '(() ()))) - - (if (and viewtag - (not (clearcase-vxpath-p directory)) - (not (eq 'view-private-object (clearcase-fprop-mtype directory)))) - - (let* ((ignore (message "Listing ClearCase modified files...")) - - (true-directory (file-truename directory)) - - ;; Form the command: - ;; - (cmd (list - "ls" - - ;; Give the directory as an argument so all names will be - ;; fullpaths. For some reason ClearCase adds an extra slash - ;; if you leave the trailing slash on the directory, so we - ;; need to remove it. - ;; - (clearcase-path-native (directory-file-name true-directory)))) - - ;; Capture the output: - ;; - (string (clearcase-path-canonicalise-slashes - (apply 'clearcase-ct-cleartool-cmd cmd))) - - ;; Split the output at the newlines: - ;; - (line-list (clearcase-utl-split-string-at-char string ?\n)) - - (hijack-list nil) - (checkout-list nil)) - - (mapcar (function - (lambda (line) - (if (string-match "^\\([^ @]+\\)@@[^ ]+ \\[hijacked\\].*" line) - (setq hijack-list (cons (substring line - (match-beginning 1) - (match-end 1)) - hijack-list))) - (if (string-match "^\\([^ @]+\\)@@.+CHECKEDOUT from .*" line) - (setq checkout-list (cons (substring line - (match-beginning 1) - (match-end 1)) - checkout-list))))) - line-list) - - (message "Listing ClearCase modified files...done") - - ;; Return the result. - ;; - (setq result (list checkout-list hijack-list)))) - result)) - -;;}}} - -;;}}} - -;; For ClearCase Dired Minor Mode -;; -(defvar clearcase-dired-mode nil) -(set-default 'clearcase-dired-mode nil) -(make-variable-buffer-local 'clearcase-dired-mode) - -;; Tell Emacs about this new kind of minor mode -;; -(if (not (assoc 'clearcase-dired-mode minor-mode-alist)) - (setq minor-mode-alist (cons '(clearcase-dired-mode clearcase-dired-mode) - minor-mode-alist))) - -;; For now we override the bindings for VC Minor Mode with ClearCase Dired -;; Minor Mode bindings. -;; -(defvar clearcase-dired-mode-map (make-sparse-keymap)) -(defvar clearcase-dired-prefix-map (make-sparse-keymap)) -(define-key clearcase-dired-mode-map "\C-xv" clearcase-dired-prefix-map) - -(define-key clearcase-dired-prefix-map "b" 'clearcase-browse-vtree-dired-file) -(define-key clearcase-dired-prefix-map "c" 'clearcase-uncheckout-dired-files) -(define-key clearcase-dired-prefix-map "e" 'clearcase-edcs-edit) -(define-key clearcase-dired-prefix-map "i" 'clearcase-mkelem-dired-files) -(define-key clearcase-dired-prefix-map "g" 'clearcase-annotate-dired-file) -(define-key clearcase-dired-prefix-map "l" 'clearcase-list-history-dired-file) -(define-key clearcase-dired-prefix-map "m" 'clearcase-mkbrtype) -(define-key clearcase-dired-prefix-map "u" 'clearcase-uncheckout-dired-files) -(define-key clearcase-dired-prefix-map "v" 'clearcase-next-action-dired-files) -(define-key clearcase-dired-prefix-map "w" 'clearcase-what-rule-dired-file) -(define-key clearcase-dired-prefix-map "=" 'clearcase-diff-pred-dired-file) -(define-key clearcase-dired-prefix-map "~" 'clearcase-version-other-window) -(define-key clearcase-dired-prefix-map "?" 'clearcase-describe-dired-file) - -;; To avoid confusion, we prevent VC Mode from being active at all by -;; undefining its keybindings for which ClearCase Mode doesn't yet have an -;; analogue. -;; -(define-key clearcase-dired-prefix-map "a" 'undefined) ;; vc-update-change-log -(define-key clearcase-dired-prefix-map "d" 'undefined) ;; vc-directory -(define-key clearcase-dired-prefix-map "h" 'undefined) ;; vc-insert-headers -(define-key clearcase-dired-prefix-map "m" 'undefined) ;; vc-merge -(define-key clearcase-dired-prefix-map "r" 'undefined) ;; vc-retrieve-snapshot -(define-key clearcase-dired-prefix-map "s" 'undefined) ;; vc-create-snapshot -(define-key clearcase-dired-prefix-map "t" 'undefined) ;; vc-dired-toggle-terse-mode - -;; Associate the map and the minor mode -;; -(or (not (boundp 'minor-mode-map-alist)) - (assq 'clearcase-dired-mode (symbol-value 'minor-mode-map-alist)) - (setq minor-mode-map-alist - (cons (cons 'clearcase-dired-mode clearcase-dired-mode-map) - minor-mode-map-alist))) - -(defun clearcase-dired-mode (&optional arg) - "The augmented Dired minor mode used in ClearCase directory buffers. -All Dired commands operate normally. Users with checked-out files -are listed in place of the file's owner and group. Keystrokes bound to -ClearCase Mode commands will execute as though they had been called -on a buffer attached to the file named in the current Dired buffer line." - - (interactive "P") - - ;; Behave like a proper minor-mode. - ;; - (setq clearcase-dired-mode - (if (interactive-p) - (if (null arg) - (not clearcase-dired-mode) - - ;; Check if the numeric arg is positive. - ;; - (> (prefix-numeric-value arg) 0)) - - ;; else - ;; Use the car if it's a list. - ;; - (if (consp arg) - (setq arg (car arg))) - - (if (symbolp arg) - (if (null arg) - (not clearcase-dired-mode) ;; toggle mode switch - (not (eq '- arg))) ;; True if symbol is not '- - - ;; else - ;; assume it's a number and check that. - ;; - (> arg 0)))) - - (if (not (eq major-mode 'dired-mode)) - (setq clearcase-dired-mode nil)) - - (if (and clearcase-dired-mode clearcase-dired-highlight) - (clearcase-dired-reformat-buffer)) - - (if clearcase-dired-mode - (easy-menu-add clearcase-dired-menu 'clearcase-dired-mode-map)) - ) - -;;}}} - -;;{{{ Major Mode: for editing comments. - -;; The major mode function. -;; -(defun clearcase-comment-mode () - "Major mode for editing comments for ClearCase. - -These bindings are added to the global keymap when you enter this mode: - -\\[clearcase-next-action-current-buffer] perform next logical version-control operation on current file -\\[clearcase-mkelem-current-buffer] mkelem the current file -\\[clearcase-toggle-read-only] like next-action, but won't create elements -\\[clearcase-list-history-current-buffer] display change history of current file -\\[clearcase-uncheckout-current-buffer] cancel checkout in buffer -\\[clearcase-diff-pred-current-buffer] show diffs between file versions -\\[clearcase-version-other-window] visit old version in another window - -While you are entering a comment for a version, the following -additional bindings will be in effect. - -\\[clearcase-comment-finish] proceed with check in, ending comment - -Whenever you do a checkin, your comment is added to a ring of -saved comments. These can be recalled as follows: - -\\[clearcase-comment-next] replace region with next message in comment ring -\\[clearcase-comment-previous] replace region with previous message in comment ring -\\[clearcase-comment-search-reverse] search backward for regexp in the comment ring -\\[clearcase-comment-search-forward] search backward for regexp in the comment ring - -Entry to the clearcase-comment-mode calls the value of text-mode-hook, then -the value of clearcase-comment-mode-hook. - -Global user options: - clearcase-initial-mkelem-comment If non-nil, require user to enter a change - comment upon first checkin of the file. - - clearcase-suppress-confirm Suppresses some confirmation prompts, - notably for reversions. - - clearcase-command-messages If non-nil, display run messages from the - actual version-control utilities (this is - intended primarily for people hacking clearcase.el - itself). -" - (interactive) - - ;; Major modes are supposed to just (kill-all-local-variables) - ;; but we rely on clearcase-parent-buffer already having been set - ;; - ;;(let ((parent clearcase-parent-buffer)) - ;; (kill-all-local-variables) - ;; (set (make-local-variable 'clearcase-parent-buffer) parent)) - - (setq major-mode 'clearcase-comment-mode) - (setq mode-name "ClearCase/Comment") - - (set-syntax-table text-mode-syntax-table) - (use-local-map clearcase-comment-mode-map) - (setq local-abbrev-table text-mode-abbrev-table) - - (make-local-variable 'clearcase-comment-operands) - (make-local-variable 'clearcase-comment-ring-index) - - (set-buffer-modified-p nil) - (setq buffer-file-name nil) - (run-hooks 'text-mode-hook 'clearcase-comment-mode-hook)) - -;; The keymap. -;; -(defvar clearcase-comment-mode-map nil) -(if clearcase-comment-mode-map - nil - (setq clearcase-comment-mode-map (make-sparse-keymap)) - (define-key clearcase-comment-mode-map "\M-n" 'clearcase-comment-next) - (define-key clearcase-comment-mode-map "\M-p" 'clearcase-comment-previous) - (define-key clearcase-comment-mode-map "\M-r" 'clearcase-comment-search-reverse) - (define-key clearcase-comment-mode-map "\M-s" 'clearcase-comment-search-forward) - (define-key clearcase-comment-mode-map "\C-c\C-c" 'clearcase-comment-finish) - (define-key clearcase-comment-mode-map "\C-x\C-s" 'clearcase-comment-save) - (define-key clearcase-comment-mode-map "\C-x\C-q" 'clearcase-comment-num-num-error)) - -;; Constants. -;; -(defconst clearcase-comment-maximum-ring-size 32 - "Maximum number of saved comments in the comment ring.") - -;; Variables. -;; -(defvar clearcase-comment-entry-mode nil) -(defvar clearcase-comment-operation nil) -(defvar clearcase-comment-operands) -(defvar clearcase-comment-ring nil) -(defvar clearcase-comment-ring-index nil) -(defvar clearcase-comment-last-match nil) -(defvar clearcase-comment-window-config nil) - -;; In several contexts, this is a local variable that points to the buffer for -;; which it was made (either a file, or a ClearCase dired buffer). -;; -(defvar clearcase-parent-buffer nil) -(defvar clearcase-parent-buffer-name nil) - -;;{{{ Commands and functions - -(defun clearcase-comment-start-entry (uniquifier - prompt - continuation - operands - &optional parent-buffer comment-seed) - - "Accept a comment by popping up a clearcase-comment-mode buffer -with a name derived from UNIQUIFIER, and emitting PROMPT in the minibuffer. -Set the continuation on close to CONTINUATION, which should be apply-ed to a list -formed by appending OPERANDS and the comment-string. - -Optional 5th argument specifies a PARENT-BUFFER to return to when the operation -is complete. - -Optional 6th argument specifies a COMMENT-SEED to insert in the comment buffer for -the user to edit." - - (let ((comment-buffer (get-buffer-create (format "*clearcase-comment-%s*" uniquifier))) - (old-window-config (current-window-configuration)) - (parent (or parent-buffer - (current-buffer)))) - (pop-to-buffer comment-buffer) - - ;; Record in buffer-local variables information sufficient to restore - ;; window context. - ;; - (set (make-local-variable 'clearcase-comment-window-config) old-window-config) - (set (make-local-variable 'clearcase-parent-buffer) parent) - - (clearcase-comment-mode) - (setq clearcase-comment-operation continuation) - (setq clearcase-comment-operands operands) - (if comment-seed - (insert comment-seed)) - (message "%s Type C-c C-c when done." prompt))) - - -(defun clearcase-comment-cleanup () - ;; Make sure it ends with newline - ;; - (goto-char (point-max)) - (if (not (bolp)) - (newline)) - - ;; Remove useless whitespace. - ;; - (goto-char (point-min)) - (while (re-search-forward "[ \t]+$" nil t) - (replace-match "")) - - ;; Remove trailing newlines, whitespace. - ;; - (goto-char (point-max)) - (skip-chars-backward " \n\t") - (delete-region (point) (point-max))) - -(defun clearcase-comment-finish () - "Complete the operation implied by the current comment." - (interactive) - - ;;Clean and record the comment in the ring. - ;; - (let ((comment-buffer (current-buffer))) - (clearcase-comment-cleanup) - - (if (null clearcase-comment-ring) - (setq clearcase-comment-ring (make-ring clearcase-comment-maximum-ring-size))) - (ring-insert clearcase-comment-ring (buffer-string)) - - ;; Perform the operation on the operands. - ;; - (if clearcase-comment-operation - (save-excursion - (apply clearcase-comment-operation - (append clearcase-comment-operands (list (buffer-string))))) - (error "No comment operation is pending")) - - ;; Return to "parent" buffer of this operation. - ;; Remove comment window. - ;; - (let ((old-window-config clearcase-comment-window-config)) - (pop-to-buffer clearcase-parent-buffer) - (delete-windows-on comment-buffer) - (kill-buffer comment-buffer) - (if old-window-config (set-window-configuration old-window-config))))) - -(defun clearcase-comment-save-comment-for-buffer (comment buffer) - (save-excursion - (set-buffer buffer) - (let ((file (buffer-file-name))) - (if (clearcase-fprop-checked-out file) - (progn - (clearcase-ct-do-cleartool-command "chevent" - file - comment - (list "-replace")) - (clearcase-fprop-set-comment file comment)) - (error "Can't change comment of checked-in version with this interface"))))) - -(defun clearcase-comment-save () - "Save the currently entered comment" - (interactive) - (let ((comment-string (buffer-string)) - (parent-buffer clearcase-parent-buffer)) - (if (not (buffer-modified-p)) - (message "(No changes need to be saved)") - (progn - (save-excursion - (set-buffer parent-buffer) - (clearcase-comment-save-comment-for-buffer comment-string parent-buffer)) - - (set-buffer-modified-p nil))))) - -(defun clearcase-comment-num-num-error () - (interactive) - (message "Perhaps you wanted to type C-c C-c instead?")) - -;; Code for the comment ring. -;; -(defun clearcase-comment-next (arg) - "Cycle forwards through comment history." - (interactive "*p") - (clearcase-comment-previous (- arg))) - -(defun clearcase-comment-previous (arg) - "Cycle backwards through comment history." - (interactive "*p") - (let ((len (ring-length clearcase-comment-ring))) - (cond ((or (not len) (<= len 0)) - (message "Empty comment ring") - (ding)) - (t - (erase-buffer) - - ;; Initialize the index on the first use of this command so that the - ;; first M-p gets index 0, and the first M-n gets index -1. - ;; - (if (null clearcase-comment-ring-index) - (setq clearcase-comment-ring-index - (if (> arg 0) -1 - (if (< arg 0) 1 0)))) - (setq clearcase-comment-ring-index - (mod (+ clearcase-comment-ring-index arg) len)) - (message "%d" (1+ clearcase-comment-ring-index)) - (insert (ring-ref clearcase-comment-ring clearcase-comment-ring-index)))))) - -(defun clearcase-comment-search-forward (str) - "Searches forwards through comment history for substring match." - (interactive "sComment substring: ") - (if (string= str "") - (setq str clearcase-comment-last-match) - (setq clearcase-comment-last-match str)) - (if (null clearcase-comment-ring-index) - (setq clearcase-comment-ring-index 0)) - (let ((str (regexp-quote str)) - (n clearcase-comment-ring-index)) - (while (and (>= n 0) (not (string-match str (ring-ref clearcase-comment-ring n)))) - (setq n (- n 1))) - (cond ((>= n 0) - (clearcase-comment-next (- n clearcase-comment-ring-index))) - (t (error "Not found"))))) - -(defun clearcase-comment-search-reverse (str) - "Searches backwards through comment history for substring match." - (interactive "sComment substring: ") - (if (string= str "") - (setq str clearcase-comment-last-match) - (setq clearcase-comment-last-match str)) - (if (null clearcase-comment-ring-index) - (setq clearcase-comment-ring-index -1)) - (let ((str (regexp-quote str)) - (len (ring-length clearcase-comment-ring)) - (n (1+ clearcase-comment-ring-index))) - (while (and (< n len) - (not (string-match str (ring-ref clearcase-comment-ring n)))) - (setq n (+ n 1))) - (cond ((< n len) - (clearcase-comment-previous (- n clearcase-comment-ring-index))) - (t (error "Not found"))))) - -;;}}} - -;;}}} - -;;{{{ Major Mode: for editing config-specs. - -;; The major mode function. -;; -(defun clearcase-edcs-mode () - (interactive) - (set-syntax-table text-mode-syntax-table) - (use-local-map clearcase-edcs-mode-map) - (setq major-mode 'clearcase-edcs-mode) - (setq mode-name "ClearCase/edcs") - (make-variable-buffer-local 'clearcase-parent-buffer) - (set-buffer-modified-p nil) - (setq buffer-file-name nil) - (run-hooks 'text-mode-hook 'clearcase-edcs-mode-hook)) - -;; The keymap. -;; -(defvar clearcase-edcs-mode-map nil) -(if clearcase-edcs-mode-map - nil - (setq clearcase-edcs-mode-map (make-sparse-keymap)) - (define-key clearcase-edcs-mode-map "\C-c\C-c" 'clearcase-edcs-finish) - (define-key clearcase-edcs-mode-map "\C-x\C-s" 'clearcase-edcs-save)) - -;; Variables. -;; -(defvar clearcase-edcs-tag-name nil - "Name of view tag which is currently being edited") - -(defvar clearcase-edcs-tag-history () - "History of view tags used in clearcase-edcs-edit") - -;;{{{ Commands - -(defun clearcase-edcs-edit (tag-name) - "Edit a ClearCase configuration specification" - - (interactive - (let ((vxname (clearcase-fprop-viewtag default-directory))) - (if clearcase-complete-viewtags - (list (directory-file-name - (completing-read "View Tag: " - (clearcase-viewtag-all-viewtags-obarray) - nil - ;;'fascist - nil - vxname - 'clearcase-edcs-tag-history))) - (read-string "View Tag: ")))) - - (let ((start (current-buffer)) - (buffer-name (format "*clearcase-config-spec-%s*" tag-name))) - (kill-buffer (get-buffer-create buffer-name)) - (pop-to-buffer (get-buffer-create buffer-name)) - (auto-save-mode auto-save-default) - (erase-buffer) - (insert (clearcase-ct-cleartool-cmd "catcs" "-tag" tag-name)) - (goto-char (point-min)) - (re-search-forward "^[^#\n]" nil 'end) - (beginning-of-line) - (clearcase-edcs-mode) - (setq clearcase-parent-buffer start) - (make-local-variable 'clearcase-edcs-tag-name) - (setq clearcase-edcs-tag-name tag-name))) - -(defun clearcase-edcs-save () - (interactive) - (if (not (buffer-modified-p)) - (message "Configuration not changed since last saved") - - (message "Setting configuration for %s..." clearcase-edcs-tag-name) - (clearcase-with-tempfile - cspec-text - (write-region (point-min) (point-max) cspec-text nil 'dont-mention-it) - (let ((ret (clearcase-ct-cleartool-cmd "setcs" - "-tag" - clearcase-edcs-tag-name - (clearcase-path-native cspec-text)))) - - ;; nyi: we could be smarter and retain viewtag info and perhaps some - ;; other info. For now invalidate all cached file property info. - ;; - (clearcase-fprop-clear-all-properties) - - (set-buffer-modified-p nil) - (message "Setting configuration for %s...done" - clearcase-edcs-tag-name))))) - -(defun clearcase-edcs-finish () - (interactive) - (let ((old-buffer (current-buffer))) - (clearcase-edcs-save) - (bury-buffer nil) - (kill-buffer old-buffer))) - -;;}}} - -;;}}} - -;;{{{ View browser - -;; nyi: Just an idea now. -;; Be able to present a selection of views at various times -;; - show me current file in other view -;; - top-level browse operation - -;; clearcase-viewtag-started-viewtags gives us the dynamic views that are mounted. - -;; How to find local snapshots ? - -;; How to find drive-letter mount points for view on NT ? -;; - parse "subst" output - -;;}}} - -;;{{{ Commands - -;;{{{ Hijack/unhijack - -(defun clearcase-hijack-current-buffer () - "Hijack the file in the current buffer." - (interactive) - (clearcase-hijack buffer-file-name)) - -(defun clearcase-hijack-dired-files () - "Hijack the selected files." - (interactive) - (clearcase-hijack-seq (dired-get-marked-files))) - -(defun clearcase-unhijack-current-buffer () - "Unhijack the file in the current buffer." - (interactive) - (clearcase-unhijack buffer-file-name)) - -(defun clearcase-unhijack-dired-files () - "Hijack the selected files." - (interactive) - (clearcase-unhijack-seq (dired-get-marked-files))) - -;;}}} - -;;{{{ Annotate - -(defun clearcase-annotate-file (file) - (let ((relative-name (file-relative-name file))) - (message "Annotating %s ..." relative-name) - (clearcase-with-tempfile - annotation-file - (clearcase-ct-do-cleartool-command "annotate" - file - 'unused - (list "-nco" - "-out" - annotation-file)) - (clearcase-utl-populate-and-view-buffer - "*clearcase-annotate*" - nil - (function - (lambda () - (insert-file-contents annotation-file))))) - (message "Annotating %s ...done" relative-name))) - -(defun clearcase-annotate-current-buffer () - (interactive) - (clearcase-annotate-file buffer-file-name)) - -(defun clearcase-annotate-dired-file () - "Annotate the selected file." - (interactive) - (clearcase-annotate-file (dired-get-filename))) - -;;}}} - -;;{{{ nyi: Find checkouts - -;; NYI: Enhance this: -;; - group by: -;; - activity name -;; - checkout comment -;; - permit unco/checkin -;; -(defun clearcase-find-checkouts-in-current-view () - "Find the checkouts in all vobs in the current view." - (interactive) - (let ((viewtag (clearcase-fprop-viewtag default-directory)) - (dir default-directory)) - (if viewtag - (let* ((ignore (message "Finding checkouts...")) - (text (clearcase-ct-blocking-call "lsco" - "-cview" - "-avobs" - "-short"))) - (if (zerop (length text)) - (message "No checkouts found") - (progn - (message "Finding checkouts...done") - - (clearcase-utl-populate-and-view-buffer - "*clearcase*" - (list text) - (function (lambda (s) - (insert s)))))))))) - -;;}}} - -;;{{{ UCM operations - -;;{{{ Make activity - -(defun clearcase-read-new-activity-name () - "Read the name of a new activity from the minibuffer. -Return nil if the empty string is entered." - - ;; nyi: Probably should check that the activity doesn't already exist. - ;; - (let ((entered-name (read-string "Activity name (optional): " ))) - (if (not (zerop (length entered-name))) - entered-name - nil))) - -(defun clearcase-read-mkact-args () - "Read the name and headline arguments for clearcase-ucm-mkact-current-dir -from the minibuffer." - - (let ((name nil) - (headline "")) - (if clearcase-prompt-for-activity-names - (setq name (clearcase-read-new-activity-name))) - (setq headline (read-string "Activity headline: " )) - (list name headline))) - -(defun clearcase-make-internally-named-activity (stream-name comment-file) - "Make a new activity in STREAM-NAME with creation comment in COMMENT-FILE, -and use an internally-generated name for the activity." - - (let ((ret - (if clearcase-set-to-new-activity - (clearcase-ct-blocking-call "mkact" - "-cfile" (clearcase-path-native comment-file) - "-in" stream-name - "-force") - (clearcase-ct-blocking-call "mkact" - "-nset" - "-cfile" (clearcase-path-native comment-file) - "-in" stream-name - "-nset" - "-force")))) - (if (string-match "Created activity \"\\([^\"]+\\)\"" ret) - (substring ret (match-beginning 1) (match-end 1)) - (error "Failed to create activity: %s" ret)))) - -(defun clearcase-ucm-mkact-current-dir (name headline &optional comment) - - "Make an activity with NAME and HEADLINE and optional COMMENT, in the stream -associated with the view associated with the current directory." - - (interactive (clearcase-read-mkact-args)) - (let* ((viewtag (clearcase-fprop-viewtag default-directory)) - (stream (clearcase-vprop-stream viewtag)) - (pvob (clearcase-vprop-pvob viewtag))) - (if (not (clearcase-vprop-ucm viewtag)) - (error "View %s is not a UCM view" viewtag)) - (if (null stream) - (error "View %s has no stream" viewtag)) - (if (null stream) - (error "View %s has no PVOB" viewtag)) - - (if (null comment) - ;; If no comment supplied, go and get one.. - ;; - (progn - (clearcase-comment-start-entry (format "new-activity-%d" (random)) - "Enter comment for new activity." - 'clearcase-ucm-mkact-current-dir - (list name headline))) - ;; ...else do the operation. - ;; - (message "Making activity...") - (clearcase-with-tempfile - comment-file - (write-region comment nil comment-file nil 'noprint) - (let ((qualified-stream (format "%s@%s" stream pvob))) - (if (stringp name) - (if clearcase-set-to-new-activity - (clearcase-ct-blocking-call "mkact" - "-cfile" (clearcase-path-native comment-file) - "-headline" headline - "-in" qualified-stream - "-force" - name) - (clearcase-ct-blocking-call "mkact" - "-nset" - "-cfile" (clearcase-path-native comment-file) - "-headline" headline - "-in" qualified-stream - "-force" - name)) - (progn - ;; If no name was provided we do the creation in two steps: - ;; mkact -force - ;; chact -headline - ;; to make sure we get preferred internally generated activity - ;; name of the form "activityNNN.MMM" rather than some horrible - ;; concoction based on the headline. - ;; - (let ((name (clearcase-make-internally-named-activity qualified-stream comment-file))) - (clearcase-ct-blocking-call "chact" - "-headline" headline - name)))))) - - ;; Flush the activities for this view so they'll get refreshed when needed. - ;; - (clearcase-vprop-flush-activities viewtag) - - (message "Making activity...done")))) - -;;}}} - -;;{{{ Set activity - -(defun clearcase-ucm-filter-out-rebases (activities) - (if (not clearcase-hide-rebase-activities) - activities - (clearcase-utl-list-filter - (function - (lambda (activity) - (let ((id (car activity))) - (not (string-match clearcase-rebase-id-regexp id))))) - activities))) - -(defun clearcase-ucm-set-activity-current-dir () - (interactive) - (let* ((viewtag (clearcase-fprop-viewtag default-directory))) - (if (not (clearcase-vprop-ucm viewtag)) - (error "View %s is not a UCM view" viewtag)) - ;; Filter out the rebases here if the user doesn't want to see them. - ;; - (let ((activities (clearcase-ucm-filter-out-rebases (clearcase-vprop-activities viewtag)))) - (if (null activities) - (error "View %s has no activities" viewtag)) - (clearcase-ucm-make-selection-window (format "*clearcase-activity-select-%s*" viewtag) - (mapconcat - (function - (lambda (activity) - (let ((id (car activity)) - (title (cdr activity))) - (format "%s\t%s" id title)))) - activities - "\n") - 'clearcase-ucm-activity-selection-interpreter - 'clearcase-ucm-set-activity - (list viewtag))))) - -(defun clearcase-ucm-activity-selection-interpreter () - "Extract the activity name from the buffer at point" - (if (looking-at "^\\(.*\\)\t") - (let ((activity-name (buffer-substring (match-beginning 1) - (match-end 1)))) - activity-name) - (error "No activity on this line"))) - -(defun clearcase-ucm-set-activity-none-current-dir () - (interactive) - (let* ((viewtag (clearcase-fprop-viewtag default-directory))) - (if (not (clearcase-vprop-ucm viewtag)) - (error "View %s is not a UCM view" viewtag)) - (clearcase-ucm-set-activity viewtag nil))) - -(defun clearcase-ucm-set-activity (viewtag activity-name) - (if activity-name - ;; Set an activity - ;; - (progn - (message "Setting activity...") - (let ((qualified-activity-name (if (string-match "@" activity-name) - activity-name - (concat activity-name "@" (clearcase-vprop-pvob viewtag))))) - (clearcase-ct-blocking-call "setactivity" "-nc" "-view" - viewtag - (if qualified-activity-name - qualified-activity-name - "-none"))) - ;; Update cache - ;; - (clearcase-vprop-set-current-activity viewtag activity-name) - (message "Setting activity...done")) - - ;; Set NO activity - ;; - (message "Unsetting activity...") - (clearcase-ct-blocking-call "setactivity" - "-nc" - "-view" viewtag - "-none") - ;; Update cache - ;; - (clearcase-vprop-set-current-activity viewtag nil) - (message "Unsetting activity...done"))) - -;;}}} - -;;{{{ Show current activity - -(defun clearcase-ucm-describe-current-activity () - (interactive) - (let* ((viewtag (clearcase-fprop-viewtag default-directory))) - (if (not viewtag) - (error "Not in a view")) - (if (not (clearcase-vprop-ucm viewtag)) - (error "View %s is not a UCM view" viewtag)) - (let ((pvob (clearcase-vprop-pvob viewtag)) - (current-activity (clearcase-vprop-current-activity viewtag))) - (if (not current-activity) - (message "No activity set") - (let ((text (clearcase-ct-blocking-call "desc" - (concat "activity:" - current-activity - "@" - pvob)))) - (if (not (zerop (length text))) - (clearcase-utl-populate-and-view-buffer - "*clearcase*" - (list text) - (function (lambda (s) - (insert s)))))))))) -;;}}} - -;;}}} - -;;{{{ Next-action - -(defun clearcase-next-action-current-buffer () - "Do the next logical operation on the current file. -Operations include mkelem, checkout, checkin, uncheckout" - (interactive) - (clearcase-next-action buffer-file-name)) - -(defun clearcase-next-action-dired-files () - "Do the next logical operation on the marked files. -Operations include mkelem, checkout, checkin, uncheckout. -If all the files are not in an equivalent state, an error is raised." - - (interactive) - (clearcase-next-action-seq (dired-get-marked-files))) - -(defun clearcase-next-action (file) - (let ((action (clearcase-compute-next-action file))) - (cond - - ((eq action 'mkelem) - (clearcase-commented-mkelem file)) - - ((eq action 'checkout) - (clearcase-commented-checkout file)) - - ((eq action 'uncheckout) - (if (yes-or-no-p "Checked-out file appears unchanged. Cancel checkout ? ") - (clearcase-uncheckout file))) - - ((eq action 'illegal-checkin) - (error "This file is checked out by someone else: %s" (clearcase-fprop-user file))) - - ((eq action 'checkin) - (clearcase-commented-checkin file)) - - (t - (error "Can't compute suitable next ClearCase action for file %s" file))))) - -(defun clearcase-next-action-seq (files) - "Do the next logical operation on the sequence of FILES." - - ;; Check they're all in the same state. - ;; - (let ((actions (mapcar (function clearcase-compute-next-action) files))) - (if (not (clearcase-utl-elts-are-eq actions)) - (error "Marked files are not all in the same state")) - (let ((action (car actions))) - (cond - - ((eq action 'mkelem) - (clearcase-commented-mkelem-seq files)) - - ((eq action 'checkout) - (clearcase-commented-checkout-seq files)) - - ((eq action 'uncheckout) - (if (yes-or-no-p "Checked-out files appears unchanged. Cancel checkouts ? ") - (clearcase-uncheckout-seq files))) - - ((eq action 'illegal-checkin) - (error "These files are checked out by someone else; will no checkin")) - - ((eq action 'checkin) - (clearcase-commented-checkin-seq files)) - - (t - (error "Can't compute suitable next ClearCase action for marked files")))))) - -(defun clearcase-compute-next-action (file) - "Compute the next logical action on FILE." - - (cond - ;; nyi: other cases to consider later: - ;; - ;; - file is unreserved - ;; - file is not mastered - - ;; Case 1: it is not yet an element - ;; ==> mkelem - ;; - ((clearcase-file-ok-to-mkelem file) - 'mkelem) - - ;; Case 2: file is not checked out - ;; ==> checkout - ;; - ((clearcase-file-ok-to-checkout file) - 'checkout) - - ;; Case 3: file is checked-out but not modified in buffer or disk - ;; ==> offer to uncheckout - ;; - ((and (clearcase-file-ok-to-uncheckout file) - (not (file-directory-p file)) - (not (buffer-modified-p)) - (not (clearcase-file-appears-modified-since-checkout-p file))) - 'uncheckout) - - ;; Case 4: file is checked-out but by somebody else using this view. - ;; ==> refuse to checkin - ;; - ;; This is not reliable on some Windows installations where a user is known - ;; as "esler" on Unix and the ClearCase server, and "ESLER" on the Windows - ;; client. - ;; - ((and (not clearcase-on-mswindows) - (clearcase-fprop-checked-out file) - (not (string= (user-login-name) - (clearcase-fprop-user file)))) - 'illegal-checkin) - - ;; Case 5: user has checked-out the file - ;; ==> check it in - ;; - ((clearcase-file-ok-to-checkin file) - 'checkin) - - (t - nil))) - -;;}}} - -;;{{{ Mkelem - -(defun clearcase-mkelem-current-buffer () - "Make the current file into a ClearCase element." - (interactive) - - ;; Watch out for new buffers of size 0: the corresponding file - ;; does not exist yet, even though buffer-modified-p is nil. - ;; - (if (and (not (buffer-modified-p)) - (zerop (buffer-size)) - (not (file-exists-p buffer-file-name))) - (set-buffer-modified-p t)) - - (clearcase-commented-mkelem buffer-file-name)) - -(defun clearcase-mkelem-dired-files () - "Make the selected files into ClearCase elements." - (interactive) - (clearcase-commented-mkelem-seq (dired-get-marked-files))) - -;;}}} - -;;{{{ Checkin - -(defun clearcase-checkin-current-buffer () - "Checkin the file in the current buffer." - (interactive) - - ;; Watch out for new buffers of size 0: the corresponding file - ;; does not exist yet, even though buffer-modified-p is nil. - ;; - (if (and (not (buffer-modified-p)) - (zerop (buffer-size)) - (not (file-exists-p buffer-file-name))) - (set-buffer-modified-p t)) - - (clearcase-commented-checkin buffer-file-name)) - -(defun clearcase-checkin-dired-files () - "Checkin the selected files." - (interactive) - (clearcase-commented-checkin-seq (dired-get-marked-files))) - -(defun clearcase-dired-checkin-current-dir () - (interactive) - (clearcase-commented-checkin (dired-current-directory))) - -;;}}} - -;;{{{ Edit checkout comment - -(defun clearcase-edit-checkout-comment-current-buffer () - "Edit the clearcase comment for the checked-out file in the current buffer." - (interactive) - (clearcase-edit-checkout-comment buffer-file-name)) - -(defun clearcase-edit-checkout-comment-dired-file () - "Checkin the selected file." - (interactive) - (clearcase-edit-checkout-comment (dired-get-filename))) - -(defun clearcase-edit-checkout-comment (file &optional comment) - "Edit comment for FILE by popping up a buffer to accept one. If COMMENT -is specified, save it." - (if (null comment) - ;; If no comment supplied, go and get one... - ;; - (clearcase-comment-start-entry (file-name-nondirectory file) - "Edit the file's check-out comment." - 'clearcase-edit-checkout-comment - (list buffer-file-name) - (find-file-noselect file) - (clearcase-fprop-comment file)) - ;; We have a comment, save it - (clearcase-comment-save-comment-for-buffer comment clearcase-parent-buffer))) - -;;}}} - -;;{{{ Checkout - -(defun clearcase-checkout-current-buffer () - "Checkout the file in the current buffer." - (interactive) - (clearcase-commented-checkout buffer-file-name)) - -(defun clearcase-checkout-dired-files () - "Checkout the selected files." - (interactive) - (clearcase-commented-checkout-seq (dired-get-marked-files))) - -(defun clearcase-dired-checkout-current-dir () - (interactive) - (clearcase-commented-checkout (dired-current-directory))) - -;;}}} - -;;{{{ Uncheckout - -(defun clearcase-uncheckout-current-buffer () - "Uncheckout the file in the current buffer." - (interactive) - (clearcase-uncheckout buffer-file-name)) - -(defun clearcase-uncheckout-dired-files () - "Uncheckout the selected files." - (interactive) - (clearcase-uncheckout-seq (dired-get-marked-files))) - -(defun clearcase-dired-uncheckout-current-dir () - (interactive) - (clearcase-uncheckout (dired-current-directory))) - -;;}}} - -;;{{{ Mkbrtype - -(defun clearcase-mkbrtype (typename) - (interactive "sBranch type name: ") - (clearcase-commented-mkbrtype typename)) - -;;}}} - -;;{{{ Describe - -(defun clearcase-describe-current-buffer () - "Give a ClearCase description of the file in the current buffer." - (interactive) - (clearcase-describe buffer-file-name)) - -(defun clearcase-describe-dired-file () - "Describe the selected files." - (interactive) - (clearcase-describe (dired-get-filename))) - -;;}}} - -;;{{{ What-rule - -(defun clearcase-what-rule-current-buffer () - (interactive) - (clearcase-what-rule buffer-file-name)) - -(defun clearcase-what-rule-dired-file () - (interactive) - (clearcase-what-rule (dired-get-filename))) - -;;}}} - -;;{{{ List history - -(defun clearcase-list-history-current-buffer () - "List the change history of the current buffer in a window." - (interactive) - (clearcase-list-history buffer-file-name)) - -(defun clearcase-list-history-dired-file () - "List the change history of the current file." - (interactive) - (clearcase-list-history (dired-get-filename))) - -;;}}} - -;;{{{ Ediff - -(defun clearcase-ediff-pred-current-buffer () - "Use Ediff to compare a version in the current buffer against its predecessor." - (interactive) - (clearcase-ediff-file-with-version buffer-file-name - (clearcase-fprop-predecessor-version buffer-file-name))) - -(defun clearcase-ediff-pred-dired-file () - "Use Ediff to compare the selected version against its predecessor." - (interactive) - (let ((truename (clearcase-fprop-truename (dired-get-filename)))) - (clearcase-ediff-file-with-version truename - (clearcase-fprop-predecessor-version truename)))) - -(defun clearcase-ediff-branch-base-current-buffer() - "Use Ediff to compare a version in the current buffer -against the base of its branch." - (interactive) - (clearcase-ediff-file-with-version buffer-file-name - (clearcase-vxpath-version-of-branch-base buffer-file-name))) - -(defun clearcase-ediff-branch-base-dired-file() - "Use Ediff to compare the selected version against the base of its branch." - (interactive) - (let ((truename (clearcase-fprop-truename (dired-get-filename)))) - (clearcase-ediff-file-with-version truename - (clearcase-vxpath-version-of-branch-base truename)))) - -(defun clearcase-ediff-named-version-current-buffer (version) - ;; nyi: if we're in history-mode, probably should just use - ;; (read-file-name) - ;; - (interactive (list (clearcase-read-version-name "Version for comparison: " - buffer-file-name))) - (clearcase-ediff-file-with-version buffer-file-name version)) - -(defun clearcase-ediff-named-version-dired-file (version) - ;; nyi: if we're in history-mode, probably should just use - ;; (read-file-name) - ;; - (interactive (list (clearcase-read-version-name "Version for comparison: " - (dired-get-filename)))) - (clearcase-ediff-file-with-version (clearcase-fprop-truename (dired-get-filename)) - version)) - -(defun clearcase-ediff-file-with-version (truename other-version) - (let ((other-vxpath (clearcase-vxpath-cons-vxpath (clearcase-vxpath-element-part truename) - other-version))) - (if (clearcase-file-is-in-mvfs-p truename) - (ediff-files other-vxpath truename) - (ediff-buffers (clearcase-vxpath-get-version-in-buffer other-vxpath) - (find-file-noselect truename t))))) - -;;}}} - -;;{{{ GUI diff - -(defun clearcase-gui-diff-pred-current-buffer () - "Use GUI to compare a version in the current buffer against its predecessor." - (interactive) - (clearcase-gui-diff-file-with-version buffer-file-name - (clearcase-fprop-predecessor-version buffer-file-name))) - -(defun clearcase-gui-diff-pred-dired-file () - "Use GUI to compare the selected version against its predecessor." - (interactive) - (let ((truename (clearcase-fprop-truename (dired-get-filename)))) - (clearcase-gui-diff-file-with-version truename - (clearcase-fprop-predecessor-version truename)))) - -(defun clearcase-gui-diff-branch-base-current-buffer() - "Use GUI to compare a version in the current buffer -against the base of its branch." - (interactive) - (clearcase-gui-diff-file-with-version buffer-file-name - (clearcase-vxpath-version-of-branch-base buffer-file-name))) - -(defun clearcase-gui-diff-branch-base-dired-file() - "Use GUI to compare the selected version against the base of its branch." - (interactive) - (let ((truename (clearcase-fprop-truename (dired-get-filename)))) - (clearcase-gui-diff-file-with-version truename - (clearcase-vxpath-version-of-branch-base truename)))) - -(defun clearcase-gui-diff-named-version-current-buffer (version) - ;; nyi: if we're in history-mode, probably should just use - ;; (read-file-name) - ;; - (interactive (list (clearcase-read-version-name "Version for comparison: " - buffer-file-name))) - (clearcase-gui-diff-file-with-version buffer-file-name version)) - -(defun clearcase-gui-diff-named-version-dired-file (version) - ;; nyi: if we're in history-mode, probably should just use - ;; (read-file-name) - ;; - (interactive (list (clearcase-read-version-name "Version for comparison: " - (dired-get-filename)))) - (clearcase-gui-diff-file-with-version (clearcase-fprop-truename (dired-get-filename)) - version)) - -(defun clearcase-gui-diff-file-with-version (truename other-version) - (let* ((other-vxpath (clearcase-vxpath-cons-vxpath (clearcase-vxpath-element-part truename) - other-version)) - (other-file (if (clearcase-file-is-in-mvfs-p truename) - other-vxpath - (clearcase-vxpath-get-version-in-temp-file other-vxpath))) - (gui-name (if clearcase-on-mswindows - "cleardiffmrg" - "xcleardiff"))) - (start-process "Diff" - nil - gui-name - (clearcase-path-native other-file) - (clearcase-path-native truename)))) - -;;}}} - -;;{{{ Diff - -(defun clearcase-diff-pred-current-buffer () - "Use Diff to compare a version in the current buffer against its predecessor." - (interactive) - (clearcase-diff-file-with-version buffer-file-name - (clearcase-fprop-predecessor-version buffer-file-name))) - -(defun clearcase-diff-pred-dired-file () - "Use Diff to compare the selected version against its predecessor." - (interactive) - (let ((truename (clearcase-fprop-truename (dired-get-filename)))) - (clearcase-diff-file-with-version truename - (clearcase-fprop-predecessor-version truename)))) - -(defun clearcase-diff-branch-base-current-buffer() - "Use Diff to compare a version in the current buffer -against the base of its branch." - (interactive) - (clearcase-diff-file-with-version buffer-file-name - (clearcase-vxpath-version-of-branch-base buffer-file-name))) - -(defun clearcase-diff-branch-base-dired-file() - "Use Diff to compare the selected version against the base of its branch." - (interactive) - (let ((truename (clearcase-fprop-truename (dired-get-filename)))) - (clearcase-diff-file-with-version truename - (clearcase-vxpath-version-of-branch-base truename)))) - -(defun clearcase-diff-named-version-current-buffer (version) - ;; nyi: if we're in history-mode, probably should just use - ;; (read-file-name) - ;; - (interactive (list (clearcase-read-version-name "Version for comparison: " - buffer-file-name))) - (clearcase-diff-file-with-version buffer-file-name version)) - -(defun clearcase-diff-named-version-dired-file (version) - ;; nyi: if we're in history-mode, probably should just use - ;; (read-file-name) - ;; - (interactive (list (clearcase-read-version-name "Version for comparison: " - (dired-get-filename)))) - (clearcase-diff-file-with-version (clearcase-fprop-truename (dired-get-filename)) - version)) - -(defun clearcase-diff-file-with-version (truename other-version) - (let ((other-vxpath (clearcase-vxpath-cons-vxpath (clearcase-vxpath-element-part truename) - other-version))) - (if (clearcase-file-is-in-mvfs-p truename) - (clearcase-diff-files other-vxpath truename) - (clearcase-diff-files (clearcase-vxpath-get-version-in-temp-file other-vxpath) - truename)))) - -;;}}} - -;;{{{ Browse vtree - -(defun clearcase-version-other-window (version) - (interactive - (list - (clearcase-read-version-name (format "Version of %s to visit: " - (file-name-nondirectory buffer-file-name)) - buffer-file-name))) - (find-file-other-window (clearcase-vxpath-cons-vxpath - (clearcase-vxpath-element-part buffer-file-name) - version))) - -(defun clearcase-browse-vtree-current-buffer () - (interactive) - (clearcase-browse-vtree buffer-file-name)) - -(defun clearcase-browse-vtree-dired-file () - (interactive) - (clearcase-browse-vtree (dired-get-filename))) - -;;}}} - -;;{{{ GUI vtree - -(defun clearcase-gui-vtree-browser-current-buffer () - (interactive) - (clearcase-gui-vtree-browser buffer-file-name)) - -(defun clearcase-gui-vtree-browser-dired-file () - (interactive) - (clearcase-gui-vtree-browser (dired-get-filename))) - -(defun clearcase-gui-vtree-browser (file) - (let ((gui-name (if clearcase-on-mswindows - "clearvtree" - "xlsvtree"))) - (start-process-shell-command "Vtree_browser" - nil - gui-name - (clearcase-path-native file)))) - -;;}}} - -;;{{{ Other GUIs - -(defun clearcase-gui-clearexplorer () - (interactive) - (start-process-shell-command "ClearExplorer" - nil - "clearexplorer" - ".")) - -(defun clearcase-gui-rebase () - (interactive) - (start-process-shell-command "Rebase" - nil - "clearmrgman" - (if clearcase-on-mswindows - "/rebase" - "-rebase"))) - -(defun clearcase-gui-deliver () - (interactive) - (start-process-shell-command "Deliver" - nil - "clearmrgman" - (if clearcase-on-mswindows - "/deliver" - "-deliver"))) - -(defun clearcase-gui-merge-manager () - (interactive) - (start-process-shell-command "Merge_manager" - nil - "clearmrgman")) - -(defun clearcase-gui-project-explorer () - (interactive) - (start-process-shell-command "Project_explorer" - nil - "clearprojexp")) - -(defun clearcase-gui-snapshot-view-updater () - (interactive) - (start-process-shell-command "View_updater" - nil - "clearviewupdate")) - -;;}}} - -;;{{{ Update snapshot - -;; In a file buffer: -;; - update current-file -;; - update directory -;; In dired: -;; - update dir -;; - update marked files -;; - update file - -;; We allow several simultaneous updates, but only one per view. - -(defun clearcase-update-view () - (interactive) - (clearcase-update (clearcase-fprop-viewtag default-directory))) - -(defun clearcase-update-default-directory () - (interactive) - (clearcase-update (clearcase-fprop-viewtag default-directory) - default-directory)) - -(defun clearcase-update-current-buffer () - (interactive) - (clearcase-update (clearcase-fprop-viewtag default-directory) - buffer-file-name)) - -(defun clearcase-update-dired-files () - (interactive) - (apply (function clearcase-update) - (cons (clearcase-fprop-viewtag default-directory) - (dired-get-marked-files)))) - - -;;}}} - -;;}}} - -;;{{{ Functions - -;;{{{ Basic ClearCase operations - -;;{{{ Update snapshot view - -;;{{{ Asynchronous post-processing of update - -(defvar clearcase-post-update-timer nil) -(defvar clearcase-post-update-work-queue nil) - -(defun clearcase-post-update-schedule-work (buffer) - (clearcase-trace "entering clearcase-post-update-schedule-work") - ;; Add to the work queue. - ;; - (setq clearcase-post-update-work-queue (cons buffer - clearcase-post-update-work-queue)) - ;; Create the timer if necessary. - ;; - (if (null clearcase-post-update-timer) - (if clearcase-xemacs-p - ;; Xemacs - ;; - (setq clearcase-post-update-timer - (run-with-idle-timer 2 t 'clearcase-post-update-timer-function)) - ;; FSF Emacs - ;; - (progn - (setq clearcase-post-update-timer (timer-create)) - (timer-set-function clearcase-post-update-timer 'clearcase-post-update-timer-function) - (timer-set-idle-time clearcase-post-update-timer 2) - (timer-activate-when-idle clearcase-post-update-timer))) - (clearcase-trace "clearcase-post-update-schedule-work: post-update timer found to be non-null"))) - - -(defun clearcase-post-update-timer-function () - (clearcase-trace "Entering clearcase-post-update-timer-function") - ;; For (each update-process buffer in the work queue) - ;; if (its process has successfully terminated) - ;; do the post-processing for this update - ;; remove it from the work queue - ;; - (clearcase-trace (format "Queue before: %s" clearcase-post-update-work-queue)) - (setq clearcase-post-update-work-queue - - (clearcase-utl-list-filter - (function clearcase-post-update-check-process-buffer) - clearcase-post-update-work-queue)) - - (clearcase-trace (format "Queue after: %s" clearcase-post-update-work-queue)) - ;; If the work queue is now empty cancel the timer. - ;; - (if (null clearcase-post-update-work-queue) - (progn - (cancel-timer clearcase-post-update-timer) - (setq clearcase-post-update-timer nil)))) - -(defun clearcase-post-update-check-process-buffer (buffer) - (clearcase-trace "Entering clearcase-post-update-check-process-buffer") - - ;; return t for those buffers that should remain in the work queue - - ;; if it has terminated successfully - ;; go sync buffers on the files that were updated - - ;; We want to field errors here and when they occurm return nil to avoid a - ;; loop - ;; - ;;(condition-case nil - - ;; protected form - (let ((proc (get-buffer-process buffer))) - (if proc - ;; Process still exists so keep this on the work queue. - ;; - (progn - (clearcase-trace "Update process still exists") - t) - - ;; Process no longer there, cleaned up by comint code. - ;; - - ;; Sync any buffers that need it. - ;; - (clearcase-trace "Update process finished") - (clearcase-sync-after-scopes-updated (with-current-buffer buffer - ;; Evaluate buffer-local variable. - ;; - clearcase-update-buffer-scopes)) - - ;; Remove from work queue - ;; - nil)) - - ;; Error occurred, make sure we return nil to remove the buffer from the - ;; work queue, or a loop could develop. - ;; - ;;(error nil) - ) - -(defun clearcase-sync-after-scopes-updated (scopes) - (clearcase-trace "Entering clearcase-sync-after-scopes-updated") - - ;; nyi: reduce scopes to minimal set of disjoint scopes - - ;; Use dynamic binding here since we don't have lexical binding. - ;; - (let ((clearcase-dynbound-updated-scopes scopes)) - - ;; For all buffers... - ;; - (mapcar - (function - (lambda (buffer) - (let ((visited-file (buffer-file-name buffer))) - (if visited-file - (if (clearcase-path-file-in-any-scopes visited-file - clearcase-dynbound-updated-scopes) - ;; This buffer visits a file within an updated scope. - ;; Sync it from disk if it needs it. - ;; - (clearcase-sync-from-disk-if-needed visited-file)) - - ;; Buffer is not visiting a file. If it is a dired-mode buffer - ;; under one of the scopes, revert it. - ;; - (with-current-buffer buffer - (if (eq 'dired-mode major-mode) - (if (clearcase-path-file-in-any-scopes default-directory - clearcase-dynbound-updated-scopes) - (dired-revert nil t)))))))) - (buffer-list)))) - -;;}}} - -;; Silence compiler complaints about free variable. -;; -(defvar clearcase-update-buffer-viewtag nil) - -(defun clearcase-update (viewtag &rest files) - "Run a cleartool+update process in VIEWTAG -if there isn't one already running in that view. -Other arguments FILES indicate files to update" - - ;; Check that there is no update process running in that view. - ;; - (if (apply (function clearcase-utl-or-func) - (mapcar (function (lambda (proc) - (if (not (eq 'exit (process-status proc))) - (let ((buf (process-buffer proc))) - (and buf - (assq 'clearcase-update-buffer-viewtag - (buffer-local-variables buf)) - (save-excursion - (set-buffer buf) - (equal viewtag - clearcase-update-buffer-viewtag))))))) - (process-list))) - (error "There is already an update running in view %s" viewtag)) - - ;; All clear so: - ;; - create a process in a buffer - ;; - rename the buffer to be of the form *clearcase-update* - ;; - mark it as one of ours by setting clearcase-update-buffer-viewtag - ;; - (pop-to-buffer (apply (function make-comint) - (append (list "*clearcase-update-temp-name*" - clearcase-cleartool-path - nil - "update") - files)) - t) ;; other window - (rename-buffer "*clearcase-update*" t) - - ;; Store in this buffer what view was being updated and what files. - ;; - (set (make-local-variable 'clearcase-update-buffer-viewtag) viewtag) - (set (make-local-variable 'clearcase-update-buffer-scopes) files) - - ;; nyi: schedule post-update buffer syncing - (clearcase-post-update-schedule-work (current-buffer))) - -;;}}} - -;;{{{ Hijack - -(defun clearcase-file-ok-to-hijack (file) - - "Test if FILE is suitable for hijack." - - (and - - ;; If it is writeable already, no need to offer a hijack operation, even - ;; though, according to ClearCase, it may not yet be hijacked. - ;; - ;;(not (file-writable-p file)) - - (not (clearcase-fprop-hijacked file)) - (clearcase-file-is-in-view-p file) - (not (clearcase-file-is-in-mvfs-p file)) - (eq 'version (clearcase-fprop-mtype file)) - (not (clearcase-fprop-checked-out file)))) - -(defun clearcase-hijack-seq (files) - (unwind-protect - (progn - (message "Hijacking...") - (mapcar - (function - (lambda (file) - (if (not (file-directory-p file)) - (clearcase-hijack file)))) - files)) - ;; Unwind - ;; - (message "Hijacking...done"))) - -(defun clearcase-hijack (file) - - ;; cases - ;; - buffer/files modtimes are equal - ;; - file more recent - ;; ==> revert - ;; - buffer more recent - ;; ==> make file writeable; save buffer ? - ;; - ;; Post-conditions: - ;; - file is hijacked wrt. CC - ;; - buffer is in sync with disk contents, modtime and writeability - ;; except if the user refused to save - ;; - (if (not (file-writable-p file)) - ;; Make it writeable. - ;; - (clearcase-utl-make-writeable file)) - - ;; Attempt to modify the modtime of the file on disk, otherwise ClearCase - ;; won't actually deem it hijacked. This will silently fail if there is no - ;; "touch" command command available. - ;; - (clearcase-utl-touch-file file) - - ;; Sync up any buffers. - ;; - (clearcase-sync-from-disk file t)) - -;;}}} - -;;{{{ Unhijack - -(defun clearcase-file-ok-to-unhijack (file) - "Test if FILE is suitable for unhijack." - (clearcase-fprop-hijacked file)) - -(defun clearcase-unhijack (file) - (clearcase-unhijack-seq (list file))) - -(defun cleartool-unhijack-parse-for-kept-files (ret snapshot-view-root) - ;; Look for occurrences of: - ;; Loading "source\emacs\.emacs.el" (296690 bytes). - ;; (renaming original hijacked object to ".emacs.el.keep.10"). - ;; - (let ((start 0) - (kept-files nil)) - (while (string-match - "^Loading \"\\([^\"]+\\)\"[^\n]+\n(renaming original hijacked object to \"\\([^\"]+\\)\")\\.\n" - ret - start) - (let* ((elt-path (substring ret (match-beginning 1) (match-end 1))) - (abs-elt-path (concat (if snapshot-view-root - snapshot-view-root - "/") - elt-path)) - (abs-elt-dir (file-name-directory abs-elt-path )) - (kept-file-rel (concat abs-elt-dir - (substring ret (match-beginning 2) (match-end 2)))) - - ;; This is necessary on Windows to get an absolute path, i.e. one - ;; with a drive letter. Note: probably only correct if - ;; unhijacking files in a single snapshot view, mounted on a - ;; drive-letter. - ;; - (kept-file (expand-file-name kept-file-rel))) - (setq kept-files (cons kept-file kept-files))) - (setq start (match-end 0))) - kept-files)) - -(defun clearcase-utl-files-in-same-view-p (files) - (if (< (length files) 2) - t - (let ((v0 (clearcase-fprop-viewtag (nth 0 files))) - (v1 (clearcase-fprop-viewtag (nth 1 files)))) - (if (or (not (stringp v0)) - (not (stringp v1)) - (not (string= v0 v1))) - nil - (clearcase-utl-files-in-same-view-p (cdr files)))))) - -(defun clearcase-unhijack-seq (files) - - ;; Check: there are no directories involved. - ;; - (mapcar - (function - (lambda (file) - (if (file-directory-p file) - (error "Cannot unhijack a directory")))) - files) - - ;; Check: all files are in the same snapshot view. - ;; - ;; (Why ? The output from ct+update only has view-root-relative paths - ;; and we need to obtain absolute paths of renamed-aside hijacks if we are to - ;; dired-relist them.) - ;; - ;; Alternative: partition the set, with each partition containing elements in - ;; the same view. - ;; - (if (not (clearcase-utl-files-in-same-view-p files)) - (error "Can't unhijack files in different views in the same operation")) - - ;; Run the scoped workspace update synchronously. - ;; - (unwind-protect - (progn - (message "Unhijacking...") - (let* ((ret (apply (function clearcase-ct-blocking-call) - (append (list "update" - (if clearcase-keep-unhijacks - "-rename" - "-overwrite") - "-log" clearcase-sink-file-name) - files))) - (snapshot-view-root (clearcase-file-snapshot-root (car files))) - - ;; Scan for renamed-aside files. - ;; - (kept-files (if clearcase-keep-unhijacks - (cleartool-unhijack-parse-for-kept-files ret - snapshot-view-root) - nil))) - - ;; Do post-update synchronisation. - ;; - (mapcar - (function clearcase-sync-after-file-updated-from-vob) - files) - - ;; Update any dired buffers as to the existence of the kept files. - ;; - (if clearcase-keep-unhijacks - (mapcar (function - (lambda (file) - (dired-relist-file file))) - kept-files)))) - ;; unwind - ;; - (message "Unhijacking...done"))) - -;;}}} - -;;{{{ Mkelem - -(defun clearcase-file-ok-to-mkelem (file) - "Test if FILE is okay to mkelem." - (let ((mtype (clearcase-fprop-mtype file))) - (and (not (file-directory-p file)) - (and (or (equal 'view-private-object mtype) - (equal 'derived-object mtype)) - (not (clearcase-fprop-hijacked file)) - (not (clearcase-file-covers-element-p file)))))) - -(defun clearcase-assert-file-ok-to-mkelem (file) - "Raise an exception if FILE is not suitable for mkelem." - (if (not (clearcase-file-ok-to-mkelem file)) - (error "%s cannot be made into an element" file))) - -(defun clearcase-commented-mkelem (file &optional okay-to-checkout-dir-first comment) - "Create a new element from FILE. If OKAY-TO-CHECKOUT-DIR-FIRST is non-nil, -the containing directory will be checked out if necessary. -If COMMENT is non-nil, it will be used, otherwise the user will be prompted -to enter one." - - ;; Pre-condition - ;; - (clearcase-assert-file-ok-to-mkelem file) - - (let ((containing-dir (file-name-directory file))) - - ;; Pre-condition - ;; - (if (not (eq 'directory-version (clearcase-fprop-mtype containing-dir))) - (error "Parent directory of %s is not a ClearCase versioned directory." - file)) - - ;; Determine if we'll need to checkout the parent directory first. - ;; - (let ((dir-checkout-needed (not (clearcase-fprop-checked-out containing-dir)))) - (if dir-checkout-needed - (progn - ;; Parent dir will need to be checked out. Get permission if - ;; appropriate. - ;; - (if (null okay-to-checkout-dir-first) - (setq okay-to-checkout-dir-first - (or (null clearcase-verify-pre-mkelem-dir-checkout) - (y-or-n-p (format "Checkout directory %s " containing-dir))))) - (if (null okay-to-checkout-dir-first) - (error "Can't make an element unless directory is checked-out.")))) - - (if (null comment) - ;; If no comment supplied, go and get one... - ;; - (clearcase-comment-start-entry (file-name-nondirectory file) - "Enter initial comment for the new element." - 'clearcase-commented-mkelem - (list file okay-to-checkout-dir-first) - (find-file-noselect file) - clearcase-initial-mkelem-comment) - - ;; ...otherwise perform the operation. - ;; - - ;; We may need to checkout the directory. - ;; - (if dir-checkout-needed - (clearcase-commented-checkout containing-dir comment)) - - (clearcase-fprop-unstore-properties file) - - (message "Making element %s..." file) - - (save-excursion - ;; Sync the buffer to disk. - ;; - (let ((buffer-on-file (find-buffer-visiting file))) - (if buffer-on-file - (progn - (set-buffer buffer-on-file) - (clearcase-sync-to-disk)))) - - (clearcase-ct-do-cleartool-command "mkelem" - file - comment - (if clearcase-checkin-on-mkelem - (list "-ci"))) - (message "Making element %s...done" file) - - ;; Resync. - ;; - (clearcase-sync-from-disk file t)))))) - -(defun clearcase-commented-mkelem-seq (files &optional comment) - "Mkelem a sequence of FILES. If COMMENT is supplied it will be -used, otherwise the user will be prompted to enter one." - - (mapcar - (function clearcase-assert-file-ok-to-mkelem) - files) - - (if (null comment) - ;; No comment supplied, go and get one... - ;; - (clearcase-comment-start-entry "mkelem" - "Enter comment for elements' creation" - 'clearcase-commented-mkelem-seq - (list files)) - ;; ...otherwise operate. - ;; - (mapcar - (function - (lambda (file) - (clearcase-commented-mkelem file nil comment))) - files))) - -;;}}} - -;;{{{ Checkin - -(defun clearcase-file-ok-to-checkin (file) - "Test if FILE is suitable for checkin." - (let ((me (user-login-name))) - (equal me (clearcase-fprop-owner-of-checkout file)))) - -(defun clearcase-assert-file-ok-to-checkin (file) - "Raise an exception if FILE is not suitable for checkin." - (if (not (clearcase-file-ok-to-checkin file)) - (error "You cannot checkin %s" file))) - -(defun clearcase-commented-checkin (file &optional comment) - "Check-in FILE with COMMENT. If the comment is omitted, -a buffer is popped up to accept one." - - (clearcase-assert-file-ok-to-checkin file) - - (if (null comment) - ;; If no comment supplied, go and get one.. - ;; - (progn - (clearcase-comment-start-entry (file-name-nondirectory file) - "Enter a checkin comment." - 'clearcase-commented-checkin - (list file) - (find-file-noselect file) - (clearcase-fprop-comment file)) - - ;; Also display a diff, if that is the custom: - ;; - (if (and (not (file-directory-p file)) - clearcase-diff-on-checkin) - (save-excursion - (let ((tmp-buffer (current-buffer))) - (message "Running diff...") - (clearcase-diff-file-with-version file - (clearcase-fprop-predecessor-version file)) - (message "Running diff...done") - (set-buffer "*clearcase*") - (if (get-buffer "*clearcase-diff*") - (kill-buffer "*clearcase-diff*")) - (rename-buffer "*clearcase-diff*") - (pop-to-buffer tmp-buffer))))) - - ;; ...otherwise perform the operation. - ;; - (message "Checking in %s..." file) - (save-excursion - ;; Sync the buffer to disk, and get local value of clearcase-checkin-arguments - ;; - (let ((buffer-on-file (find-buffer-visiting file))) - (if buffer-on-file - (progn - (set-buffer buffer-on-file) - (clearcase-sync-to-disk)))) - (clearcase-ct-do-cleartool-command "ci" - file - comment - clearcase-checkin-arguments)) - (message "Checking in %s...done" file) - - ;; Resync. - ;; - (clearcase-sync-from-disk file t))) - -(defun clearcase-commented-checkin-seq (files &optional comment) - "Checkin a sequence of FILES. If COMMENT is supplied it will be -used, otherwise the user will be prompted to enter one." - - ;; Check they're all in the right state to be checked-in. - ;; - (mapcar - (function clearcase-assert-file-ok-to-checkin) - files) - - (if (null comment) - ;; No comment supplied, go and get one... - ;; - (clearcase-comment-start-entry "checkin" - "Enter checkin comment." - 'clearcase-commented-checkin-seq - (list files)) - ;; ...otherwise operate. - ;; - (mapcar - (function - (lambda (file) - (clearcase-commented-checkin file comment))) - files))) - -;;}}} - -;;{{{ Checkout - -(defun clearcase-file-ok-to-checkout (file) - "Test if FILE is suitable for checkout." - (let ((mtype (clearcase-fprop-mtype file))) - (and (or (eq 'version mtype) - (eq 'directory-version mtype) - (clearcase-fprop-hijacked file)) - (not (clearcase-fprop-checked-out file))))) - -(defun clearcase-assert-file-ok-to-checkout (file) - "Raise an exception if FILE is not suitable for checkout." - (if (not (clearcase-file-ok-to-checkout file)) - (error "You cannot checkout %s" file))) - -;; nyi: Offer to setact if appropriate - -(defun clearcase-commented-checkout (file &optional comment) - "Check-out FILE with COMMENT. If the comment is omitted, -a buffer is popped up to accept one." - - (clearcase-assert-file-ok-to-checkout file) - - (if (and (null comment) - (not clearcase-suppress-checkout-comments)) - ;; If no comment supplied, go and get one... - ;; - (clearcase-comment-start-entry (file-name-nondirectory file) - "Enter a checkout comment." - 'clearcase-commented-checkout - (list file) - (find-file-noselect file)) - - ;; ...otherwise perform the operation. - ;; - (message "Checking out %s..." file) - ;; Change buffers to get local value of clearcase-checkin-arguments. - ;; - (save-excursion - (set-buffer (or (find-buffer-visiting file) - (current-buffer))) - (clearcase-ct-do-cleartool-command "co" - file - comment - clearcase-checkout-arguments)) - (message "Checking out %s...done" file) - - ;; Resync. - ;; - (clearcase-sync-from-disk file t))) - - -(defun clearcase-commented-checkout-seq (files &optional comment) - "Checkout a sequence of FILES. If COMMENT is supplied it will be -used, otherwise the user will be prompted to enter one." - - (mapcar - (function clearcase-assert-file-ok-to-checkout) - files) - - (if (and (null comment) - (not clearcase-suppress-checkout-comments)) - ;; No comment supplied, go and get one... - ;; - (clearcase-comment-start-entry "checkout" - "Enter a checkout comment." - 'clearcase-commented-checkout-seq - (list files)) - ;; ...otherwise operate. - ;; - (mapcar - (function - (lambda (file) - (clearcase-commented-checkout file comment))) - files))) - -;;}}} - -;;{{{ Uncheckout - -(defun clearcase-file-ok-to-uncheckout (file) - "Test if FILE is suitable for uncheckout." - (equal (user-login-name) - (clearcase-fprop-owner-of-checkout file))) - -(defun clearcase-assert-file-ok-to-uncheckout (file) - "Raise an exception if FILE is not suitable for uncheckout." - (if (not (clearcase-file-ok-to-uncheckout file)) - (error "You cannot uncheckout %s" file))) - -(defun cleartool-unco-parse-for-kept-file (ret) - ;;Private version of "foo" saved in "foo.keep.1" - (if (string-match "^Private version of .* saved in \"\\([^\"]+\\)\"\\.$" ret) - (substring ret (match-beginning 1) (match-end 1)) - nil)) - -(defun clearcase-uncheckout (file) - "Uncheckout FILE." - - (clearcase-assert-file-ok-to-uncheckout file) - - ;; If it has changed since checkout, insist the user confirm. - ;; - (if (and (not (file-directory-p file)) - (clearcase-file-appears-modified-since-checkout-p file) - (not clearcase-suppress-confirm) - (not (yes-or-no-p (format "Really discard changes to %s ?" file)))) - (message "Uncheckout of %s cancelled" file) - - ;; Go ahead and unco. - ;; - (message "Cancelling checkout of %s..." file) - ;; nyi: - ;; - Prompt for -keep or -rm - ;; - offer to remove /0 branches - ;; - (let* ((ret (clearcase-ct-blocking-call "unco" - (if clearcase-keep-uncheckouts - "-keep" - "-rm") - file)) - ;; Discover the name of the saved. - ;; - (kept-file (if clearcase-keep-uncheckouts - (cleartool-unco-parse-for-kept-file ret) - nil))) - - (if kept-file - (message "Checkout of %s cancelled (saved in %s)" - (file-name-nondirectory kept-file) - file) - (message "Cancelling checkout of %s...done" file)) - - ;; Sync any buffers over the file itself. - ;; - (clearcase-sync-from-disk file t) - - ;; Update any dired buffers as to the existence of the kept file. - ;; - (if kept-file - (dired-relist-file kept-file))))) - -(defun clearcase-uncheckout-seq (files) - "Uncheckout a sequence of FILES." - - (mapcar - (function clearcase-assert-file-ok-to-uncheckout) - files) - - (mapcar - (function clearcase-uncheckout) - files)) - -;;}}} - -;;{{{ Describe - -(defun clearcase-describe (file) - "Give a ClearCase description of FILE." - - (clearcase-utl-populate-and-view-buffer - "*clearcase*" - (list file) - (function - (lambda (file) - (clearcase-ct-do-cleartool-command "describe" file 'unused))))) - -(defun clearcase-describe-seq (files) - "Give a ClearCase description of the sequence of FILES." - (error "Not yet implemented")) - -;;}}} - -;;{{{ Mkbrtype - -(defun clearcase-commented-mkbrtype (typename &optional comment) - (if (null comment) - (clearcase-comment-start-entry (format "mkbrtype:%s" typename) - "Enter a comment for the new branch type." - 'clearcase-commented-mkbrtype - (list typename)) - (clearcase-with-tempfile - comment-file - (write-region comment nil comment-file nil 'noprint) - (let ((qualified-typename typename)) - (if (not (string-match "@" typename)) - (setq qualified-typename - (format "%s@%s" typename default-directory))) - - (clearcase-ct-cleartool-cmd "mkbrtype" - "-cfile" - (clearcase-path-native comment-file) - qualified-typename))))) - -;;}}} - -;;{{{ Browse vtree (using Dired Mode) - -(defun clearcase-file-ok-to-browse (file) - (and file - (or (equal 'version (clearcase-fprop-mtype file)) - (equal 'directory-version (clearcase-fprop-mtype file))) - (clearcase-file-is-in-mvfs-p file))) - -(defun clearcase-browse-vtree (file) - (if (not (clearcase-fprop-file-is-version-p file)) - (error "%s is not a Clearcase element" file)) - - (if (not (clearcase-file-is-in-mvfs-p file)) - (error "File is not in MVFS")) - - (let* ((version-path (clearcase-vxpath-cons-vxpath - file - (or (clearcase-vxpath-version-part file) - (clearcase-fprop-version file)))) - ;; nyi: Can't seem to get latest first here. - ;; - (dired-listing-switches (concat dired-listing-switches - "rt")) - - (branch-path (clearcase-vxpath-branch version-path)) - - ;; Position cursor to the version we came from. - ;; If it was checked-out, go to predecessor. - ;; - (version-number (clearcase-vxpath-version - (if (clearcase-fprop-checked-out file) - (clearcase-fprop-predecessor-version file) - version-path)))) - - (if (file-exists-p version-path) - (progn - ;; Invoke dired on the directory of the version branch. - ;; - (dired branch-path) - - (clearcase-dired-sort-by-date) - - (if (re-search-forward (concat "[ \t]+" - "\\(" - (regexp-quote version-number) - "\\)" - "$") - nil - t) - (goto-char (match-beginning 1)))) - (dired (concat file clearcase-vxpath-glue)) - - ;; nyi: We want ANY directory in the history tree to appear with - ;; newest first. Probably requires a hook to dired mode. - ;; - (clearcase-dired-sort-by-date)))) - -;;}}} - -;;{{{ List history - -(defun clearcase-list-history (file) - "List the change history of FILE. - -FILE can be a file or a directory. If it is a directory, only the information -on the directory element itself is listed, not on its contents." - - (let ((mtype (clearcase-fprop-mtype file))) - (if (or (eq mtype 'version) - (eq mtype 'directory-version)) - (progn - (message "Listing element history...") - - (clearcase-utl-populate-and-view-buffer - "*clearcase*" - (list file) - (function - (lambda (file) - (clearcase-ct-do-cleartool-command "lshistory" - file - 'unused - (if (eq mtype 'directory-version) - (list "-d"))) - (setq default-directory (file-name-directory file)) - (while (looking-at "=3D*\n") - (delete-char (- (match-end 0) (match-beginning 0))) - (forward-line -1)) - (goto-char (point-min)) - (if (looking-at "[\b\t\n\v\f\r ]+") - (delete-char (- (match-end 0) (match-beginning 0))))))) - (message "Listing element history...done")) - - (error "%s is not a ClearCase element" file)))) - -;;}}} - -;;{{{ Diff/cmp - -(defun clearcase-files-are-identical (f1 f2) - "Test if FILE1 and FILE2 have identical contents." - - (clearcase-when-debugging - (if (not (file-exists-p f1)) - (error "%s non-existent" f1)) - (if (not (file-exists-p f2)) - (error "%s non-existent" f2))) - - (zerop (call-process "cleardiff" nil nil nil "-status_only" f1 f2))) - -(defun clearcase-diff-files (file1 file2) - "Run cleardiff on FILE1 and FILE2 and display the differences." - (if clearcase-use-normal-diff - (clearcase-do-command 2 - clearcase-normal-diff-program - file2 - (append clearcase-normal-diff-arguments - (list file1))) - (clearcase-do-command 2 - "cleardiff" - file2 - (list "-diff_format" file1))) - (let ((diff-size (save-excursion - (set-buffer "*clearcase*") - (buffer-size)))) - (if (zerop diff-size) - (message "No differences") - (clearcase-port-view-buffer-other-window "*clearcase*") - (goto-char 0) - (shrink-window-if-larger-than-buffer)))) - -;;}}} - -;;{{{ What rule - -(defun clearcase-what-rule (file) - (let ((result (clearcase-ct-cleartool-cmd "ls" - "-d" - (clearcase-path-native file)))) - (if (string-match "Rule: \\(.*\\)\n" result) - (message (substring result - ;; Be a little more verbose - (match-beginning 0) (match-end 1))) - (error result)))) - -;;}}} - -;;}}} - -;;{{{ File property cache - -;; ClearCase properties of files are stored in a vector in a hashtable with the -;; absolute-filename (with no trailing slashes) as the lookup key. -;; -;; Properties are: -;; -;; [0] truename : string -;; [1] mtype : { nil, view-private-object, version, -;; directory-version, file-element, -;; dir-element, derived-object -;; } -;; [2] checked-out : boolean -;; [3] reserved : boolean -;; [4] version : string -;; [5] predecessor-version : string -;; [6] oid : string -;; [7] user : string -;; [8] date : string (yyyymmdd.hhmmss) -;; [9] time-last-described : (N, N, N) time when the properties were last read -;; from ClearCase -;; [10] viewtag : string -;; [11] comment : string -;; [12] slink-text : string (empty string if not symlink) -;; [13] hijacked : boolean - -;; nyi: other possible properties to record: -;; mtime when last described (lets us know when the cached properties -;; might be stale) - -;;{{{ Debug code - -(defun clearcase-fprop-unparse-properties (properties) - "Return a string suitable for printing PROPERTIES." - (concat - (format "truename: %s\n" (aref properties 0)) - (format "mtype: %s\n" (aref properties 1)) - (format "checked-out: %s\n" (aref properties 2)) - (format "reserved: %s\n" (aref properties 3)) - (format "version: %s\n" (aref properties 4)) - (format "predecessor-version: %s\n" (aref properties 5)) - (format "oid: %s\n" (aref properties 6)) - (format "user: %s\n" (aref properties 7)) - (format "date: %s\n" (aref properties 8)) - (format "time-last-described: %s\n" (current-time-string (aref properties 9))) - (format "viewtag: %s\n" (aref properties 10)) - (format "comment: %s\n" (aref properties 11)) - (format "slink-text: %s\n" (aref properties 12)) - (format "hijacked: %s\n" (aref properties 13)))) - -(defun clearcase-fprop-display-properties (file) - "Display the recorded ClearCase properties of FILE." - (interactive "F") - (let* ((abs-file (expand-file-name file)) - (properties (clearcase-fprop-lookup-properties abs-file))) - (if properties - (let ((unparsed-properties (clearcase-fprop-unparse-properties properties))) - (clearcase-utl-populate-and-view-buffer - "*clearcase*" - nil - (function (lambda () - (insert unparsed-properties))))) - (error "Properties for %s not stored" file)))) - -(defun clearcase-fprop-dump-to-current-buffer () - "Dump to the current buffer the table recording ClearCase properties of files." - (interactive) - (insert (format "File describe count: %s\n" clearcase-fprop-describe-count)) - (mapatoms - (function - (lambda (symbol) - (let ((properties (symbol-value symbol))) - (insert "\n" - (format "key: %s\n" (symbol-name symbol)) - "\n" - (clearcase-fprop-unparse-properties properties))))) - clearcase-fprop-hashtable) - (insert "\n")) - -(defun clearcase-fprop-dump () - (interactive) - (clearcase-utl-populate-and-view-buffer - "*clearcase*" - nil - (function (lambda () - (clearcase-fprop-dump-to-current-buffer))))) - -;;}}} - -(defvar clearcase-fprop-hashtable (make-vector 31 0) - "Obarray for per-file ClearCase properties.") - -(defun clearcase-fprop-canonicalise-path (filename) - ;; We want DIR/y and DIR\y to map to the same cache entry on ms-windows. - ;; We want DIR and DIR/ (and on windows DIR\) to map to the same cache entry. - ;; - ;; However, on ms-windows avoid canonicalising X:/ to X: because, for some - ;; reason, cleartool+desc fails on X:, but works on X:/ - ;; - (setq filename (clearcase-path-canonicalise-slashes filename)) - (if (and clearcase-on-mswindows - (string-match (concat "^" "[A-Za-z]:" clearcase-pname-sep-regexp "$") - filename)) - filename - (clearcase-utl-strip-trailing-slashes filename))) - -(defun clearcase-fprop-clear-all-properties () - "Delete all entries in the clearcase-fprop-hashtable." - (setq clearcase-fprop-hashtable (make-vector 31 0))) - -(defun clearcase-fprop-store-properties (file properties) - "For FILE, store its ClearCase PROPERTIES in the clearcase-fprop-hashtable." - (assert (file-name-absolute-p file)) - (set (intern (clearcase-fprop-canonicalise-path file) - clearcase-fprop-hashtable) properties)) - -(defun clearcase-fprop-unstore-properties (file) - "For FILE, delete its entry in the clearcase-fprop-hashtable." - (assert (file-name-absolute-p file)) - (unintern (clearcase-fprop-canonicalise-path file) clearcase-fprop-hashtable)) - -(defun clearcase-fprop-lookup-properties (file) - "For FILE, lookup and return its ClearCase properties from the -clearcase-fprop-hashtable." - (assert (file-name-absolute-p file)) - (symbol-value (intern-soft (clearcase-fprop-canonicalise-path file) - clearcase-fprop-hashtable))) - -(defun clearcase-fprop-get-properties (file) - "For FILE, make sure its ClearCase properties are in the hashtable -and then return them." - (or (clearcase-fprop-lookup-properties file) - (let ((properties - (condition-case signal-info - (clearcase-fprop-read-properties file) - (error - (progn - (clearcase-trace (format "(clearcase-fprop-read-properties %s) signalled error: %s" - file - (cdr signal-info))) - (make-vector 31 nil)))))) - (clearcase-fprop-store-properties file properties) - properties))) - -(defun clearcase-fprop-truename (file) - "For FILE, return its \"truename\" ClearCase property." - (aref (clearcase-fprop-get-properties file) 0)) - -(defun clearcase-fprop-mtype (file) - "For FILE, return its \"mtype\" ClearCase property." - (aref (clearcase-fprop-get-properties file) 1)) - -(defun clearcase-fprop-checked-out (file) - "For FILE, return its \"checked-out\" ClearCase property." - (aref (clearcase-fprop-get-properties file) 2)) - -(defun clearcase-fprop-reserved (file) - "For FILE, return its \"reserved\" ClearCase property." - (aref (clearcase-fprop-get-properties file) 3)) - -(defun clearcase-fprop-version (file) - "For FILE, return its \"version\" ClearCase property." - (aref (clearcase-fprop-get-properties file) 4)) - -(defun clearcase-fprop-predecessor-version (file) - "For FILE, return its \"predecessor-version\" ClearCase property." - (aref (clearcase-fprop-get-properties file) 5)) - -(defun clearcase-fprop-oid (file) - "For FILE, return its \"oid\" ClearCase property." - (aref (clearcase-fprop-get-properties file) 6)) - -(defun clearcase-fprop-user (file) - "For FILE, return its \"user\" ClearCase property." - (aref (clearcase-fprop-get-properties file) 7)) - -(defun clearcase-fprop-date (file) - "For FILE, return its \"date\" ClearCase property." - (aref (clearcase-fprop-get-properties file) 8)) - -(defun clearcase-fprop-time-last-described (file) - "For FILE, return its \"time-last-described\" ClearCase property." - (aref (clearcase-fprop-get-properties file) 9)) - -(defun clearcase-fprop-viewtag (file) - "For FILE, return its \"viewtag\" ClearCase property." - (aref (clearcase-fprop-get-properties file) 10)) - -(defun clearcase-fprop-comment (file) - "For FILE, return its \"comment\" ClearCase property." - (aref (clearcase-fprop-get-properties file) 11)) - -(defun clearcase-fprop-vob-slink-text (file) - "For FILE, return its \"slink-text\" ClearCase property." - (aref (clearcase-fprop-get-properties file) 12)) - -(defun clearcase-fprop-hijacked (file) - "For FILE, return its \"hijacked\" ClearCase property." - (aref (clearcase-fprop-get-properties file) 13)) - -(defun clearcase-fprop-set-comment (file comment) - "For FILE, set its \"comment\" ClearCase property to COMMENT." - (aset (clearcase-fprop-get-properties file) 11 comment)) - -(defun clearcase-fprop-owner-of-checkout (file) - "For FILE, return whether the current user has it checked-out." - (if (clearcase-fprop-checked-out file) - (clearcase-fprop-user file) - nil)) - -(defun clearcase-fprop-file-is-vob-slink-p (object-name) - (not (zerop (length (clearcase-fprop-vob-slink-text object-name))))) - -(defun clearcase-fprop-file-is-version-p (object-name) - (if object-name - (let ((mtype (clearcase-fprop-mtype object-name))) - (or (eq 'version mtype) - (eq 'directory-version mtype))))) - -;; Read the object's ClearCase properties using cleartool and the Lisp reader. -;; -;; nyi: for some reason the \n before the %c necessary here so avoid confusing the -;; cleartool/tq interface. Completely mysterious. Arrived at by -;; trial and error. -;; -(defvar clearcase-fprop-fmt-string - - ;; Yuck. Different forms of quotation are needed here apparently to deal with - ;; all the various ways of spawning sub-process on the the various platforms - ;; (XEmacs vs. GnuEmacs, Win32 vs. Unix, Cygwin-built vs. native-built). - ;; - (if clearcase-on-mswindows - (if clearcase-xemacs-p - ;; XEmacs/Windows - ;; - (if clearcase-on-cygwin - ;; Cygwin build - ;; - "[nil \\\"%m\\\" \\\"%f\\\" \\\"%Rf\\\" \\\"%Sn\\\" \\\"%PSn\\\" \\\"%On\\\" \\\"%u\\\" \\\"%Nd\\\" nil nil nil \\\"%[slink_text]p\\\" nil ]\\n%c" - ;; Native build - ;; - "[nil \\\"%m\\\" \\\"%f\\\" \\\"%Rf\\\" \\\"%Sn\\\" \\\"%PSn\\\" \\\"%On\\\" \\\"%u\\\" \\\"%Nd\\\" nil nil nil \\\"%[slink_text]p\\\" nil]\n%c") - - ;; GnuEmacs/Windows - ;; - "[nil \"%m\" \"%f\" \"%Rf\" \"%Sn\" \"%PSn\" \"%On\" \"%u\" \"%Nd\" nil nil nil \"%[slink_text]p\" nil]\\n%c") - - ;; Unix - ;; - "'[nil \"%m\" \"%f\" \"%Rf\" \"%Sn\" \"%PSn\" \"%On\" \"%u\" \"%Nd\" nil nil nil \"%[slink_text]p\" nil]\\n%c'") - - "Format for cleartool+describe command when reading the -ClearCase properties of a file") - -(defvar clearcase-fprop-describe-count 0 - "Count the number of times clearcase-fprop-read-properties is called") - -(defun clearcase-fprop-read-properties (file) - "Invoke the cleartool+describe command to obtain the ClearCase -properties of FILE." - (assert (file-name-absolute-p file)) - (let* ((truename (clearcase-fprop-canonicalise-path (file-truename (expand-file-name file))))) - - ;; If the object doesn't exist, signal an error - ;; - (if (or (not (file-exists-p (clearcase-vxpath-element-part file))) - (not (file-exists-p (clearcase-vxpath-element-part truename)))) - (error "File doesn't exist: %s" file) - - ;; Run cleartool+ describe and capture the output as a string: - ;; - (let ((desc-string (clearcase-ct-cleartool-cmd "desc" - "-fmt" - clearcase-fprop-fmt-string - (clearcase-path-native truename)))) - (setq clearcase-fprop-describe-count (1+ clearcase-fprop-describe-count)) - - ;;(clearcase-trace (format "desc of %s <<<<" truename)) - ;;(clearcase-trace desc-string) - ;;(clearcase-trace (format "desc of %s >>>>" truename)) - - ;; Read all but the comment, using the Lisp reader, and then copy - ;; what's left as the comment. We don't try to use the Lisp reader to - ;; fetch the comment to avoid problems with quotation. - ;; - ;; nyi: it would be nice if we could make cleartool use "/" as pname-sep, - ;; because read-from-string will barf on imbedded "\". For now - ;; run clearcase-path-canonicalise-slashes over the cleartool - ;; output before invoking the Lisp reader. - ;; - (let* ((first-read (read-from-string (clearcase-path-canonicalise-slashes desc-string))) - (result (car first-read)) - (bytes-read (cdr first-read)) - (comment (substring desc-string (1+ bytes-read)))) ;; skip \n - - ;; Plug in the slots I left empty: - ;; - (aset result 0 truename) - (aset result 9 (current-time)) - - (aset result 11 comment) - - ;; Convert mtype to an enumeration: - ;; - (let ((mtype-string (aref result 1))) - (cond - ((string= mtype-string "version") - (aset result 1 'version)) - - ((string= mtype-string "directory version") - (aset result 1 'directory-version)) - - ((string= mtype-string "view private object") - (aset result 1 'view-private-object) - - ;; If we're in a snapshot see if it is hijacked by running - ;; ct+desc FILE@@. No error indicates it's hijacked. - ;; - (if (clearcase-file-would-be-in-snapshot-p truename) - (aset result 13 - (condition-case nil - (stringp - (clearcase-ct-cleartool-cmd - "desc" - "-short" - (concat (clearcase-path-native truename) - clearcase-vxpath-glue))) - (error nil))))) - - ((string= mtype-string "file element") - (aset result 1 'file-element)) - - ((string= mtype-string "directory element") - (aset result 1 'directory-element)) - - ((string= mtype-string "derived object") - (aset result 1 'derived-object)) - - ;; For now treat checked-in DOs as versions. - ;; - ((string= mtype-string "derived object version") - (aset result 1 'version)) - - ;; On NT, coerce the mtype of symlinks into that - ;; of their targets. - ;; - ;; nyi: I think this is approximately right. - ;; - ((and (string= mtype-string "symbolic link") - clearcase-on-mswindows) - (if (file-directory-p truename) - (aset result 1 'directory-version) - (aset result 1 'version))) - - ;; We get this on paths like foo.c@@/main - ;; - ((string= mtype-string "branch") - (aset result 1 'branch)) - - ((string= mtype-string "**null meta type**") - (aset result 1 nil)) - - (t - (error "Unknown mtype returned by cleartool+describe: %s" - mtype-string)))) - - ;; nyi: possible efficiency win: only evaluate the viewtag on demand. - ;; - (if (aref result 1) - (aset result 10 (clearcase-file-viewtag truename))) - - ;; Convert checked-out field to boolean: - ;; - (aset result 2 (not (zerop (length (aref result 2))))) - - ;; Convert reserved field to boolean: - ;; - (aset result 3 (string= "reserved" (aref result 3))) - - ;; Return the array of properties. - ;; - result))))) - -;;}}} - -;;{{{ View property cache - -;; ClearCase properties of views are stored in a vector in a hashtable -;; with the viewtag as the lookup key. -;; -;; Properties are: -;; -;; [0] ucm : boolean -;; [1] stream : string -;; [2] pvob : string -;; [3] activities : list of strings -;; [4] current-activity : string - -;;{{{ Debug code - -(defun clearcase-vprop-dump-to-current-buffer () - "Dump to the current buffer the table recording ClearCase properties of views." - (insert (format "View describe count: %s\n" clearcase-vprop-describe-count)) - (mapatoms - (function - (lambda (symbol) - (let ((properties (symbol-value symbol))) - (insert "\n" - (format "viewtag: %s\n" (symbol-name symbol)) - "\n" - (clearcase-vprop-unparse-properties properties))))) - clearcase-vprop-hashtable) - (insert "\n")) - -(defun clearcase-vprop-dump () - (interactive) - (clearcase-utl-populate-and-view-buffer - "*clearcase*" - nil - (function (lambda () - (clearcase-vprop-dump-to-current-buffer))))) - -(defun clearcase-vprop-unparse-properties (properties) - "Return a string suitable for printing PROPERTIES." - (concat - (format "ucm: %s\n" (aref properties 0)) - (format "stream: %s\n" (aref properties 1)) - (format "pvob: %s\n" (aref properties 2)) - (format "activities: %s\n" (aref properties 3)) - (format "current-activity: %s\n" (aref properties 4)))) - -;;}}} - -;;{{{ Asynchronously fetching view properties: - -(defvar clearcase-vprop-timer nil) -(defvar clearcase-vprop-work-queue nil) - -(defun clearcase-vprop-schedule-work (viewtag) - ;; Add to the work queue. - ;; - (setq clearcase-vprop-work-queue (cons viewtag - clearcase-vprop-work-queue)) - ;; Create the timer if necessary. - ;; - (if (null clearcase-vprop-timer) - (if clearcase-xemacs-p - ;; Xemacs - ;; - (setq clearcase-vprop-timer - (run-with-idle-timer 5 t 'clearcase-vprop-timer-function)) - ;; FSF Emacs - ;; - (progn - (setq clearcase-vprop-timer (timer-create)) - (timer-set-function clearcase-vprop-timer 'clearcase-vprop-timer-function) - (timer-set-idle-time clearcase-vprop-timer 5) - (timer-activate-when-idle clearcase-vprop-timer))))) - -(defun clearcase-vprop-timer-function () - ;; Process the work queue and empty it. - ;; - (mapcar (function (lambda (viewtag) - (clearcase-vprop-get-properties viewtag))) - clearcase-vprop-work-queue) - (setq clearcase-vprop-work-queue nil) - - ;; Cancel the timer. - ;; - (cancel-timer clearcase-vprop-timer) - (setq clearcase-vprop-timer nil)) - -;;}}} - -(defvar clearcase-vprop-hashtable (make-vector 31 0) - "Obarray for per-view ClearCase properties.") - -(defun clearcase-vprop-clear-all-properties () - "Delete all entries in the clearcase-vprop-hashtable." - (setq clearcase-vprop-hashtable (make-vector 31 0))) - -(defun clearcase-vprop-store-properties (viewtag properties) - "For VIEW, store its ClearCase PROPERTIES in the clearcase-vprop-hashtable." - (set (intern viewtag clearcase-vprop-hashtable) properties)) - -(defun clearcase-vprop-unstore-properties (viewtag) - "For VIEWTAG, delete its entry in the clearcase-vprop-hashtable." - (unintern viewtag clearcase-vprop-hashtable)) - -(defun clearcase-vprop-lookup-properties (viewtag) - "For VIEWTAG, lookup and return its ClearCase properties from the -clearcase-vprop-hashtable." - (symbol-value (intern-soft viewtag clearcase-vprop-hashtable))) - -(defun clearcase-vprop-get-properties (viewtag) - "For VIEWTAG, make sure it's ClearCase properties are in the hashtable -and then return them." - (or (clearcase-vprop-lookup-properties viewtag) - (let ((properties (clearcase-vprop-read-properties viewtag))) - (clearcase-vprop-store-properties viewtag properties) - properties))) - -(defun clearcase-vprop-ucm (viewtag) - "For VIEWTAG, return its \"ucm\" ClearCase property." - (aref (clearcase-vprop-get-properties viewtag) 0)) - -(defun clearcase-vprop-stream (viewtag) - "For VIEWTAG, return its \"stream\" ClearCase property." - (aref (clearcase-vprop-get-properties viewtag) 1)) - -(defun clearcase-vprop-pvob (viewtag) - "For VIEWTAG, return its \"stream\" ClearCase property." - (aref (clearcase-vprop-get-properties viewtag) 2)) - -(defun clearcase-vprop-activities (viewtag) - "For VIEWTAG, return its \"activities\" ClearCase property." - - ;; If the activity set has been flushed, go and schedule a re-fetch. - ;; - (let ((properties (clearcase-vprop-get-properties viewtag))) - (if (null (aref properties 3)) - (aset properties 3 (clearcase-vprop-read-activities-asynchronously viewtag)))) - - ;; Now poll, waiting for the activities to be available. - ;; - (let ((loop-count 0)) - ;; If there is a background process still reading the activities, - ;; wait for it to finish. - ;; - ;; nyi: probably want a timeout here. - ;; - ;; nyi: There seems to be a race on NT in accept-process-output so that - ;; we would wait forever. - ;; - (if (not clearcase-on-mswindows) - ;; Unix synchronization with the end of the process - ;; which is reading activities. - ;; - (while (bufferp (aref (clearcase-vprop-get-properties viewtag) 3)) - (save-excursion - (set-buffer (aref (clearcase-vprop-get-properties viewtag) 3)) - (message "Reading activity list...") - (setq loop-count (1+ loop-count)) - (accept-process-output clearcase-vprop-async-proc))) - - ;; NT synchronization with the end of the process which is reading - ;; activities. - ;; - ;; Unfortunately on NT we can't rely on the process sentinel being called - ;; so we have to explicitly test the process status. - ;; - (while (bufferp (aref (clearcase-vprop-get-properties viewtag) 3)) - (message "Reading activity list...") - (save-excursion - (set-buffer (aref (clearcase-vprop-get-properties viewtag) 3)) - (if (or (not (processp clearcase-vprop-async-proc)) - (eq 'exit (process-status clearcase-vprop-async-proc))) - - ;; The process has finished or gone away and apparently - ;; the sentinel didn't get called which would have called - ;; clearcase-vprop-finish-reading-activities, so call it - ;; explicitly here. - ;; - (clearcase-vprop-finish-reading-activities (current-buffer)) - - ;; The process is apparently still running, so wait - ;; so more. - (setq loop-count (1+ loop-count)) - (sit-for 1))))) - - (if (not (zerop loop-count)) - (message "Reading activity list...done")) - - (aref (clearcase-vprop-get-properties viewtag) 3))) - -(defun clearcase-vprop-current-activity (viewtag) - "For VIEWTAG, return its \"current-activity\" ClearCase property." - (aref (clearcase-vprop-get-properties viewtag) 4)) - -(defun clearcase-vprop-set-activities (viewtag activities) - "For VIEWTAG, set its \"activities\" ClearCase property to ACTIVITIES." - (let ((properties (clearcase-vprop-lookup-properties viewtag))) - ;; We must only set the activities for an existing vprop entry. - ;; - (assert properties) - (aset properties 3 activities))) - -(defun clearcase-vprop-flush-activities (viewtag) - "For VIEWTAG, set its \"activities\" ClearCase property to nil, -to cause a future re-fetch." - (clearcase-vprop-set-activities viewtag nil)) - -(defun clearcase-vprop-set-current-activity (viewtag activity) - "For VIEWTAG, set its \"current-activity\" ClearCase property to ACTIVITY." - (aset (clearcase-vprop-get-properties viewtag) 4 activity)) - -;; Read the object's ClearCase properties using cleartool lsview and cleartool lsstream. - -(defvar clearcase-vprop-describe-count 0 - "Count the number of times clearcase-vprop-read-properties is called") - -(defvar clearcase-lsstream-fmt-string - (if clearcase-on-mswindows - (if clearcase-xemacs-p - ;; XEmacs/Windows - ;; - (if clearcase-on-cygwin - ;; Cygwin build - ;; - "[\\\"%n\\\" \\\"%[master]p\\\" ]" - ;; Native build - ;; - "[\\\"%n\\\" \\\"%[master]p\\\" ]") - ;; GnuEmacs/Windows - ;; - "[\"%n\" \"%[master]p\" ]") - ;; Unix - ;; - "'[\"%n\" \"%[master]p\" ]'")) - -(defun clearcase-vprop-read-properties (viewtag) - "Invoke cleartool commands to obtain the ClearCase -properties of VIEWTAG." - - ;; We used to use "ct+lsview -properties -full TAG", but this seemed to take - ;; a long time in some circumstances. It appears to be because the - ;; ADM_VIEW_GET_INFO RPC can take up to 60 seconds in certain circumstances - ;; (typically on my laptop with self-contained ClearCase region). - - ;; Accordingly, since we don't really need to store snapshotness, the minimum - ;; we really need to discover about a view is whether it is UCM-attached. For - ;; this the much faster ct+lsstream suffices. - ;; - (let* ((result (make-vector 5 nil))) - (if (not clearcase-v3) - (let ((ucm nil) - (stream nil) - (pvob nil) - (activity-names nil) - (activity-titles nil) - (activities nil) - (current-activity nil) - (ret "")) - - ;; This was necessary to make sure the "done" message was always - ;; displayed. Not quite sure why. - ;; - (unwind-protect - (progn - (message "Reading view properties...") - (setq ret (clearcase-ct-blocking-call "lsstream" "-fmt" - clearcase-lsstream-fmt-string - "-view" viewtag)) - - (setq clearcase-vprop-describe-count (1+ clearcase-vprop-describe-count)) - - (if (setq ucm (not (zerop (length ret)))) - - ;; It's apparently a UCM view - ;; - (let* ((first-read (read-from-string (clearcase-utl-escape-backslashes ret))) - (array-read (car first-read)) - (bytes-read (cdr first-read))) - - ;; Get stream name - ;; - (setq stream (aref array-read 0)) - - ;; Get PVOB tag from something like "unix@/vobs/projects" - ;; - (let ((s (aref array-read 1))) - (if (string-match "@" s) - (setq pvob (substring s (match-end 0))) - (setq pvob s))) - - ;; Get the activity list and store as a list of (NAME . TITLE) pairs - ;; - (setq activities (clearcase-vprop-read-activities-asynchronously viewtag)) - - ;; Get the current activity - ;; - (let ((name-string (clearcase-ct-blocking-call "lsact" "-cact" "-fmt" "%n" - "-view" viewtag))) - (if (not (zerop (length name-string))) - (setq current-activity name-string))) - - (aset result 0 ucm) - (aset result 1 stream) - (aset result 2 pvob) - (aset result 3 activities) - (aset result 4 current-activity)))) - - (message "Reading view properties...done")))) - - result)) - -(defvar clearcase-vprop-async-viewtag nil) -(defvar clearcase-vprop-async-proc nil) -(defun clearcase-vprop-read-activities-asynchronously (viewtag) - (let ((buf-name (format "*clearcase-activities-%s*" viewtag))) - ;; Clean up old instance of the buffer we use to fetch activities: - ;; - (let ((buf (get-buffer buf-name))) - (if buf - (progn - (save-excursion - (set-buffer buf) - (if (and (boundp 'clearcase-vprop-async-proc) - clearcase-vprop-async-proc) - (condition-case nil - (kill-process clearcase-vprop-async-proc) - (error nil)))) - (kill-buffer buf)))) - - ;; Create a buffer and an associated new process to read activities in the - ;; background. We return the buffer to be stored in the activities field of - ;; the view-properties record. The function clearcase-vprop-activities will - ;; recognise when the asynch fetching is still underway and wait for it to - ;; finish. - ;; - ;; The process has a sentinel function which is supposed to get called when - ;; the process finishes. This sometimes doesn't happen on Windows, so that - ;; clearcase-vprop-activities has to do a bit more work. (Perhaps a race - ;; exists: the process completes before the sentinel can be set ?) - ;; - (let* ((buf (get-buffer-create buf-name)) - (proc (start-process (format "*clearcase-activities-process-%s*" viewtag) - buf - clearcase-cleartool-path - "lsact" "-view" viewtag))) - (process-kill-without-query proc) - (save-excursion - (set-buffer buf) - ;; Create a sentinel to parse and store the activities when the - ;; process finishes. We record the viewtag as a buffer-local - ;; variable so the sentinel knows where to store the activities. - ;; - (set (make-local-variable 'clearcase-vprop-async-viewtag) viewtag) - (set (make-local-variable 'clearcase-vprop-async-proc) proc) - (set-process-sentinel proc 'clearcase-vprop-read-activities-sentinel)) - ;; Return the buffer. - ;; - buf))) - -(defun clearcase-vprop-read-activities-sentinel (process event-string) - (clearcase-trace "Activity reading process sentinel called") - (if (not (equal "finished\n" event-string)) - ;; Failure - ;; - (error "Reading activities failed: %s" event-string)) - (clearcase-vprop-finish-reading-activities (process-buffer process))) - -(defun clearcase-vprop-finish-reading-activities (buffer) - (let ((activity-list nil)) - (message "Parsing view activities...") - (save-excursion - (set-buffer buffer) - (if (or (not (boundp 'clearcase-vprop-async-viewtag)) - (null clearcase-vprop-async-viewtag)) - (error "Internal error: clearcase-vprop-async-viewtag not set")) - - ;; Check that our buffer is the one currently expected to supply the - ;; activities. (Avoid races.) - ;; - (let ((properties (clearcase-vprop-lookup-properties clearcase-vprop-async-viewtag))) - (if (and properties - (eq buffer (aref properties 3))) - (progn - - ;; Parse the buffer, slicing out the 2nd and 4th fields as name and title. - ;; - (goto-char (point-min)) - (while (re-search-forward "^[^ \t]+[ \t]+\\([^ \t]+\\)[ \t]+[^ \t]+[ \t]+\"+\\(.*\\)\"$" nil t) - (let ((id (buffer-substring (match-beginning 1) - (match-end 1))) - (title (buffer-substring (match-beginning 2) - (match-end 2)))) - (setq activity-list (cons (cons id title) - activity-list)))) - - ;; We've got activity-list in the reverse order that - ;; cleartool+lsactivity generated them. I think this is reverse - ;; chronological order, so keep this order since it is more - ;; convenient when setting to an activity. - ;; - ;;(setq activity-list (nreverse activity-list)) - - (clearcase-vprop-set-activities clearcase-vprop-async-viewtag activity-list)) - - (kill-buffer buffer)))) - (message "Parsing view activities...done"))) - -;;{{{ old synchronous activity reader - -;; (defun clearcase-vprop-read-activities-synchronously (viewtag) -;; "Return a list of (activity-name . title) pairs for VIEWTAG" -;; ;; nyi: ought to use a variant of clearcase-ct-blocking-call that returns a buffer -;; ;; rather than a string - -;; ;; Performance: takes around 30 seconds to read 1000 activities. -;; ;; Too slow to invoke willy-nilly on integration streams for example, -;; ;; which typically can have 1000+ activities. - -;; (let ((ret (clearcase-ct-blocking-call "lsact" "-view" viewtag))) -;; (let ((buf (get-buffer-create "*clearcase-temp-activities*")) -;; (activity-list nil)) -;; (save-excursion -;; (set-buffer buf) -;; (erase-buffer) -;; (insert ret) -;; (goto-char (point-min)) -;; ;; Slice out the 2nd and 4th fields as name and title -;; ;; -;; (while (re-search-forward "^[^ \t]+[ \t]+\\([^ \t]+\\)[ \t]+[^ \t]+[ \t]+\"+\\(.*\\)\"$" nil t) -;; (setq activity-list (cons (cons (buffer-substring (match-beginning 1) -;; (match-end 1)) -;; (buffer-substring (match-beginning 2) -;; (match-end 2))) -;; activity-list))) -;; (kill-buffer buf)) - -;; ;; We've got activity-list in the reverse order that -;; ;; cleartool+lsactivity generated them. I think this is reverse -;; ;; chronological order, so keep this order since it is more -;; ;; convenient when setting to an activity. -;; ;; -;; ;;(nreverse activity-list)))) -;; activity-list))) - -;;}}} - -;;}}} - -;;{{{ Determining if a checkout was modified. - -;; How to tell if a file changed since checkout ? -;; -;; In the worst case we actually run "ct diff -pred" but we attempt several -;; less expensive tests first. -;; -;; 1. If it's size differs from pred. -;; 2. The mtime and the ctime are no longer the same. -;; -;; nyi: Other cheaper tests we could use: -;; -;; (a) After each Emacs-driven checkout go and immediately fetch the mtime of -;; the file and store as fprop-checkout-mtime. Then use that to compare -;; against current mtime. This at least would make this function work -;; right on files checked out by the current Emacs process. -;; -;; (b) In the MVFS, after each Emacs-driven checkout go and immediately fetch -;; the OID and store as fprop-checkout-oid. Then use that to compare -;; against the current oid (the MVFS assigns a new OID at each write). -;; This might not always be a win since we'd still need to run cleartool -;; to get the current OID. - -(defun clearcase-file-appears-modified-since-checkout-p (file) - "Return whether FILE appears to have been modified since checkout. -It doesn't examine the file contents." - - (if (not (clearcase-fprop-checked-out file)) - nil - - (let ((mvfs (clearcase-file-is-in-mvfs-p file))) - - ;; We consider various cases in order of increasing cost to compute. - - (cond - ;; Case 1: (MVFS only) the size is different to its predecessor. - ;; - ((and mvfs - (not - (equal - (clearcase-utl-file-size file) - ;; nyi: For the snapshot case it'd be nice to get the size of the - ;; predecessor by using "ct+desc -pred -fmt" but there doesn't - ;; seem to be a format descriptor for file size. On the other hand - ;; ct+dump can obtain the size. - ;; - (clearcase-utl-file-size (clearcase-vxpath-cons-vxpath - file - (clearcase-fprop-predecessor-version - file))))) - ;; Return: - ;; - 'size-changed)) - - ;; Case 2: (MVFS only) the mtime and the ctime are no longer the same. - ;; - ;; nyi: At least on Windows there seems to be a small number of seconds - ;; difference here even when the file is not modified. - ;; So we really check to see of they are close. - ;; - ;; nyi: This doesn't work in a snapshot view. - ;; - ((and mvfs - (not (clearcase-utl-filetimes-close (clearcase-utl-file-mtime file) - (clearcase-utl-file-ctime file) - 5)) - ;; Return: - ;; - 'ctime-mtime-not-close)) - - (t - ;; Case 3: last resort. Actually run a diff against predecessor. - ;; - (let ((ret (clearcase-ct-blocking-call "diff" - "-options" - "-quiet" - "-pred" - file))) - (if (not (zerop (length ret))) - ;; Return: - ;; - 'diffs-nonempty - - ;; Return: - ;; - nil))))))) - -;;}}} - -;;{{{ Tests for view-residency - -;;{{{ Tests for MVFS file residency - -;; nyi: probably superseded by clearcase-file-would-be-in-view-p -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; nyi: this should get at least partially invalidated when -;; VOBs are unmounted. - -;; nyi: make this different for NT -;; -(defvar clearcase-always-mvfs-regexp (if (not clearcase-on-mswindows) - "^/vobs/[^/]+/" - - ;; nyi: express this using drive variable - ;; - (concat "^" - "[Mm]:" - clearcase-pname-sep-regexp))) - -;; This prevents the clearcase-file-vob-root function from pausing for long periods -;; stat-ing /net/host@@ -;; -;; nyi: is there something equivalent on NT I need to avoid ? -;; - -(defvar clearcase-never-mvfs-regexps (if clearcase-on-mswindows - nil - '( - "^/net/[^/]+/" - "^/tmp_mnt/net/[^/]+/" - )) - "Regexps matching those paths we can assume are never inside the MVFS.") - -(defvar clearcase-known-vob-root-cache nil) - -(defun clearcase-file-would-be-in-mvfs-p (filename) - "Return whether FILE, after it is created, would reside in an MVFS filesystem." - (let ((truename (file-truename filename))) - (if (file-exists-p truename) - (clearcase-file-is-in-mvfs-p truename) - (let ((containing-dir (file-name-as-directory (file-name-directory truename)))) - (clearcase-file-is-in-mvfs-p containing-dir))))) - -(defun clearcase-file-is-in-mvfs-p (filename) - "Return whether existing FILE, resides in an MVFS filesystem." - (let ((truename (file-truename filename))) - - (or - ;; case 1: its prefix matches an "always VOB" prefix like /vobs/... - ;; - ;; nyi: problem here: we return true for "/vobs/nonexistent/" - ;; - (numberp (string-match clearcase-always-mvfs-regexp truename)) - - ;; case 2: it has a prefix which is a known VOB-root - ;; - (clearcase-file-matches-vob-root truename clearcase-known-vob-root-cache) - - ;; case 3: it has an ancestor dir which is a newly met VOB-root - ;; - (clearcase-file-vob-root truename)))) - -(defun clearcase-wd-is-in-mvfs () - "Return whether the current directory resides in an MVFS filesystem." - (clearcase-file-is-in-mvfs-p (file-truename "."))) - -(defun clearcase-file-matches-vob-root (truename vob-root-list) - "Return whether TRUENAME has a prefix in VOB-ROOT-LIST." - (if (null vob-root-list) - nil - (or (numberp (string-match (regexp-quote (car vob-root-list)) - truename)) - (clearcase-file-matches-vob-root truename (cdr vob-root-list))))) - -(defun clearcase-file-vob-root (truename) - "File the highest versioned directory in TRUENAME." - - ;; Use known non-MVFS patterns to rule some paths out. - ;; - (if (apply (function clearcase-utl-or-func) - (mapcar (function (lambda (regexp) - (string-match regexp truename))) - clearcase-never-mvfs-regexps)) - nil - (let ((previous-dir nil) - (dir (file-name-as-directory (file-name-directory truename))) - (highest-versioned-directory nil)) - - (while (not (string-equal dir previous-dir)) - (if (clearcase-file-covers-element-p dir) - (setq highest-versioned-directory dir)) - (setq previous-dir dir) - (setq dir (file-name-directory (directory-file-name dir)))) - - (if highest-versioned-directory - (add-to-list 'clearcase-known-vob-root-cache highest-versioned-directory)) - - highest-versioned-directory))) - -;; Note: you should probably be using clearcase-fprop-mtype instead of this -;; unless you really know what you're doing (nyi: check usages of this.) -;; -(defun clearcase-file-covers-element-p (path) - "Determine quickly if PATH refers to a Clearcase element, -without caching the result." - - ;; nyi: Even faster: consult the fprop cache first ? - - (let ((element-dir (concat (clearcase-vxpath-element-part path) clearcase-vxpath-glue))) - (and (file-exists-p path) - (file-directory-p element-dir)))) - -;;}}} - -;;{{{ Tests for snapshot view residency - -;; nyi: probably superseded by clearcase-file-would-be-in-view-p -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defvar clearcase-known-snapshot-root-cache nil) - -(defun clearcase-file-would-be-in-snapshot-p (filename) - "Return whether FILE, after it is created, would reside in a snapshot view. -If so, return the viewtag." - (let ((truename (file-truename filename))) - (if (file-exists-p truename) - (clearcase-file-is-in-snapshot-p truename) - (let ((containing-dir (file-name-as-directory (file-name-directory truename)))) - (clearcase-file-is-in-snapshot-p containing-dir))))) - -(defun clearcase-file-is-in-snapshot-p (truename) - "Return whether existing FILE, resides in a snapshot view. -If so, return the viewtag." - - (or - ;; case 1: it has a prefix which is a known snapshot-root - ;; - (clearcase-file-matches-snapshot-root truename clearcase-known-snapshot-root-cache) - - ;; case 2: it has an ancestor dir which is a newly met VOB-root - ;; - (clearcase-file-snapshot-root truename))) - -(defun clearcase-wd-is-in-snapshot () - "Return whether the current directory resides in a snapshot view." - (clearcase-file-is-in-snapshot-p (file-truename "."))) - -(defun clearcase-file-matches-snapshot-root (truename snapshot-root-list) - "Return whether TRUENAME has a prefix in SNAPSHOT-ROOT-LIST." - (if (null snapshot-root-list) - nil - (or (numberp (string-match (regexp-quote (car snapshot-root-list)) - truename)) - (clearcase-file-matches-snapshot-root truename (cdr snapshot-root-list))))) - -;; This prevents the clearcase-file-snapshot-root function from pausing for long periods -;; stat-ing /net/host@@ -;; -;; nyi: is there something equivalent on NT I need to avoid ? -;; - -(defvar clearcase-never-snapshot-regexps (if clearcase-on-mswindows - nil - '( - "^/net/[^/]+/" - "^/tmp_mnt/net/[^/]+/" - )) - "Regexps matching those paths we can assume are never inside a snapshot view.") - -(defun clearcase-file-snapshot-root (truename) - "File the the snapshot view root containing TRUENAME." - - ;; Use known non-snapshot patterns to rule some paths out. - ;; - (if (apply (function clearcase-utl-or-func) - (mapcar (function (lambda (regexp) - (string-match regexp truename))) - clearcase-never-snapshot-regexps)) - nil - (let ((previous-dir nil) - (dir (file-name-as-directory (file-name-directory truename))) - (viewtag nil) - (viewroot nil)) - - - (while (and (not (string-equal dir previous-dir)) - (null viewtag)) - - ;; See if .view.dat exists and contains a valid view uuid - ;; - (let ((view-dat-name (concat dir (if clearcase-on-mswindows - "view.dat" ".view.dat")))) - (if (file-readable-p view-dat-name) - (let ((uuid (clearcase-viewdat-to-uuid view-dat-name))) - (if uuid - (progn - (setq viewtag (clearcase-view-uuid-to-tag uuid)) - (if viewtag - (setq viewroot dir))))))) - - (setq previous-dir dir) - (setq dir (file-name-directory (directory-file-name dir)))) - - (if viewroot - (add-to-list 'clearcase-known-snapshot-root-cache viewroot)) - - ;; nyi: update a viewtag==>viewroot map ? - - viewroot))) - -(defun clearcase-viewdat-to-uuid (file) - "Extract the view-uuid from a .view.dat file." - ;; nyi, but return non-nil so clearcase-file-snapshot-root works - t - ) - -(defun clearcase-view-uuid-to-tag (uuid) - "Look up the view-uuid in the register to discover its tag." - ;; nyi, but return non-nil so clearcase-file-snapshot-root works - t - ) - -;;}}} - -;; This is simple-minded but seems to work because cleartool+describe -;; groks snapshot views. -;; -;; nyi: Might be wise to cache view-roots to speed this up because the -;; filename-handlers call this. -;; -;; nyi: Some possible shortcuts -;; 1. viewroot-relative path [syntax] -;; 2. under m:/ on NT [syntax] -;; 3. setviewed on Unix [find a containing VOB-root] -;; 4. subst-ed view on NT (calling net use seems very slow though) -;; [find a containing VOB-root] -;; 5. snapshot view -;; -(defun clearcase-file-would-be-in-view-p (filename) - "Return whether FILE, after it is created, would reside in a ClearCase view." - (let ((truename (file-truename (expand-file-name filename)))) - - ;; We use clearcase-path-file-really-exists-p here to make sure we are dealing - ;; with a real file and not something faked by Emacs' file name handlers - ;; like Ange-FTP. - ;; - (if (clearcase-path-file-really-exists-p truename) - (clearcase-file-is-in-view-p truename) - (let ((containing-dir (file-name-as-directory (file-name-directory truename)))) - (and (clearcase-path-file-really-exists-p containing-dir) - (clearcase-file-is-in-view-p containing-dir)))))) - -(defun clearcase-file-is-in-view-p (filename) - (let ((truename (file-truename (expand-file-name filename)))) - ;; Shortcut if the file is a version-extended path. - ;; - (or (clearcase-file-snapshot-root truename) - (clearcase-vxpath-p truename) - (clearcase-fprop-mtype truename) - - ;; nyi: How to efficiently know if we're in a dynamic-view root - ;; 1. Test each contained name for elementness. - ;; Too inefficient. - ;; 2. If it is viewroot-relative. - ;; Okay but not sufficient. - ;; How about case v:/ when view is substed ? - ;; 3. We're setviewed. - ;; Okay but not sufficient. - ;; Maintain a cache of viewroots ? - ))) - -(defun clearcase-file-viewtag (filename) - "Find the viewtag associated with existing FILENAME." - - (clearcase-when-debugging - (assert (file-exists-p filename))) - - (let ((truename (file-truename (expand-file-name filename)))) - (cond - - ;; Case 1: viewroot-relative path - ;; ==> syntax - ;; - ((clearcase-vrpath-p truename) - (clearcase-vrpath-viewtag truename)) - - ;; Case 2: under m:/ on NT - ;; ==> syntax - ;; - ((and clearcase-on-mswindows - (string-match (concat clearcase-viewroot-drive - clearcase-pname-sep-regexp - "\\(" - clearcase-non-pname-sep-regexp "*" - "\\)" - ) - truename)) - (substring truename (match-beginning 1) (match-end 1))) - - ;; Case 3: setviewed on Unix - ;; ==> read EV, but need to check it's beneath a VOB-root - ;; - ((and clearcase-setview-viewtag - (clearcase-file-would-be-in-mvfs-p truename)) - clearcase-setview-viewtag) - - ;; Case 4: subst-ed view on NT - ;; ==> use ct+pwv -wdview - ;; Case 5: snapshot view - ;; ==> use ct+pwv -wdview - (t - (clearcase-file-wdview truename))))) - -(defun clearcase-file-wdview (truename) - "Return the working-directory view associated with TRUENAME, -or nil if none" - (let ((default-directory (if (file-directory-p truename) - truename - (file-name-directory truename)))) - (clearcase-ct-cd default-directory) - (let ((ret (clearcase-ct-blocking-call "pwv" "-wdview" "-short"))) - (if (not (string-match " NONE " ret)) - (clearcase-utl-1st-line-of-string ret))))) - -;;}}} - -;;{{{ The cleartool sub-process - -;; We use pipes rather than pty's for two reasons: -;; -;; 1. NT only has pipes -;; 2. On Solaris there appeared to be a problem in the pty handling part -;; of Emacs, which resulted in Emacs/tq seeing too many cleartool prompt -;; strings. This would occasionally occur and prevent the tq-managed -;; interactions with the cleartool sub-process from working correctly. -;; -;; Now we use pipes. Cleartool detects the "non-tty" nature of the output -;; device and doesn't send a prompt. We manufacture an end-of-transaction -;; marker by sending a "pwd -h" after each cleartool sub-command and then use -;; the expected output of "Usage: pwd\n" as our end-of-txn pattern for tq. -;; -;; Even using pipes, the semi-permanent outboard-process using tq doesn't work -;; well on NT. There appear to be bugs in accept-process-output such that: -;; 0. there apparently were hairy race conditions, which a sprinkling -;; of (accept-process-output nil 1) seemed to avoid somewhat. -;; 1. it never seems to timeout if you name a process as arg1. -;; 2. it always seems to wait for TIMEOUT, even if there is output ready. -;; The result seemed to be less responsive tha just calling a fresh cleartool -;; process for each invocation of clearcase-ct-blocking-call -;; -;; It still seems worthwhile to make it work on NT, as clearcase-ct-blocking-call -;; typically takes about 0.5 secs on NT versus 0.05 sec on Solaris, -;; an order of magnitude difference. -;; - -(defconst clearcase-ct-eotxn-cmd "pwd -h\n") -(defconst clearcase-ct-eotxn-response "Usage: pwd\n") -(defconst clearcase-ct-eotxn-response-length (length clearcase-ct-eotxn-response)) - -(defconst clearcase-ct-subproc-timeout 30 - "Timeout on calls to subprocess") - -(defvar clearcase-ct-tq nil - "Transaction queue to talk to ClearTool in a subprocess") - -(defvar clearcase-ct-return nil - "Return value when we're involved in a blocking call") - -(defvar clearcase-ct-view "" - "Current view of cleartool subprocess, or the empty string if none") - -(defvar clearcase-ct-wdir "" - "Current working directory of cleartool subprocess, -or the empty string if none") - -(defvar clearcase-ct-running nil) - -(defun clearcase-ct-accept-process-output (proc timeout) - (accept-process-output proc timeout)) - -(defun clearcase-ct-start-cleartool () - (interactive) - (clearcase-trace "clearcase-ct-start-cleartool()") - (let ((process-environment (append '("ATRIA_NO_BOLD=1" - "ATRIA_FORCE_GUI=1") - ;;; emacs is a GUI, right? :-) - process-environment))) - (clearcase-trace (format "Starting cleartool in %s" default-directory)) - (let* ( ;; Force the use of a pipe - ;; - (process-connection-type nil) - (cleartool-process - (start-process "cleartool" ;; Absolute path won't work here - " *cleartool*" - clearcase-cleartool-path))) - (process-kill-without-query cleartool-process) - (setq clearcase-ct-view "") - (setq clearcase-ct-tq (tq-create cleartool-process)) - (tq-enqueue clearcase-ct-tq - clearcase-ct-eotxn-cmd ;; question - clearcase-ct-eotxn-response ;; regexp - 'clearcase-ct-running ;; closure - 'set) ;; function - (while (not clearcase-ct-running) - (message "waiting for cleartool to start...") - (clearcase-ct-accept-process-output (tq-process clearcase-ct-tq) - clearcase-ct-subproc-timeout)) - ;; Assign a sentinel to restart it if it dies. - ;; nyi: This needs debugging. - ;;(set-process-sentinel cleartool-process 'clearcase-ct-sentinel) - - (clearcase-trace "clearcase-ct-start-cleartool() done") - (message "waiting for cleartool to start...done")))) - -;; nyi: needs debugging. -;; -(defun clearcase-ct-sentinel (process event-string) - (clearcase-trace (format "Cleartool process sentinel called: %s" event-string)) - (if (not (eq 'run (process-status process))) - (progn - ;; Restart the dead cleartool. - ;; - (clearcase-trace "Cleartool process restarted") - (clearcase-ct-start-cleartool)))) - -(defun clearcase-ct-kill-cleartool () - "Kill off cleartool subprocess. If another one is needed, -it will be restarted. This may be useful if you're debugging clearcase." - (interactive) - (clearcase-ct-kill-tq)) - -(defun clearcase-ct-callback (arg val) - (clearcase-trace (format "clearcase-ct-callback:<\n")) - (clearcase-trace val) - (clearcase-trace (format "clearcase-ct-callback:>\n")) - ;; This can only get called when the last thing received from - ;; the cleartool sub-process was clearcase-ct-eotxn-response, - ;; so it is safe to just remove it here. - ;; - (setq clearcase-ct-return (substring val 0 (- clearcase-ct-eotxn-response-length)))) - -(defun clearcase-ct-do-cleartool-command (command file comment &optional extra-args) - "Execute a cleartool command, notifying user and checking for -errors. Output from COMMAND goes to buffer *clearcase*. The last argument of the -command is the name of FILE; this is appended to an optional list of -EXTRA-ARGS." - - (if file - (setq file (expand-file-name file))) - (if (listp command) - (error "command must not be a list")) - (if clearcase-command-messages - (if file - (message "Running %s on %s..." command file) - (message "Running %s..." command))) - (let ((camefrom (current-buffer)) - (squeezed nil) - status) - (set-buffer (get-buffer-create "*clearcase*")) - (setq buffer-read-only nil) - (erase-buffer) - (set (make-local-variable 'clearcase-parent-buffer) camefrom) - (set (make-local-variable 'clearcase-parent-buffer-name) - (concat " from " (buffer-name camefrom))) - - ;; This is so that command arguments typed in the *clearcase* buffer will - ;; have reasonable defaults. - ;; - (if file - (setq default-directory (file-name-directory file))) - - (mapcar - (function (lambda (s) - (and s - (not (zerop (length s))) - (setq squeezed - (append squeezed (list s)))))) - extra-args) - - (clearcase-with-tempfile - comment-file - (if (not (eq comment 'unused)) - (if comment - (progn - (write-region comment nil comment-file nil 'noprint) - (setq squeezed (append squeezed (list "-cfile" (clearcase-path-native comment-file))))) - (setq squeezed (append squeezed (list "-nc"))))) - (if file - (setq squeezed (append squeezed (list (clearcase-path-native file))))) - (let ((default-directory (file-name-directory - (or file default-directory)))) - (clearcase-ct-cd default-directory) - (if clearcase-command-messages - (message "Running %s..." command)) - (insert - (apply 'clearcase-ct-cleartool-cmd (append (list command) squeezed))) - (if clearcase-command-messages - (message "Running %s...done" command)))) - - (goto-char (point-min)) - (clearcase-view-mode 0 camefrom) - (set-buffer-modified-p nil) ; XEmacs - fsf uses `not-modified' - (if (re-search-forward "^cleartool: Error:.*$" nil t) - (progn - (setq status (buffer-substring (match-beginning 0) (match-end 0))) - (clearcase-port-view-buffer-other-window "*clearcase*") - (shrink-window-if-larger-than-buffer) - (error "Running %s...FAILED (%s)" command status)) - (if clearcase-command-messages - (message "Running %s...OK" command))) - (set-buffer camefrom) - status)) - -(defun clearcase-ct-cd (dir) - (if (or (not dir) - (string= dir clearcase-ct-wdir)) - clearcase-ct-wdir - (clearcase-ct-blocking-call "cd" (clearcase-path-native dir)) - (setq clearcase-ct-wdir dir))) - -(defun clearcase-ct-cleartool-cmd (&rest cmd) - (apply 'clearcase-ct-blocking-call cmd)) - -;; NT Emacs - needs a replacement for tq. -;; -(defun clearcase-ct-get-command-stdout (program &rest args) - "Call PROGRAM. -Returns PROGRAM's stdout. -ARGS is the command line arguments to PROGRAM." - (let ((buf (get-buffer-create "cleartoolexecution"))) - (prog1 - (save-excursion - (set-buffer buf) - (apply 'call-process program nil buf nil args) - (buffer-string)) - (kill-buffer buf)))) - -;; The TQ interaction still doesn't work on NT. -;; -(defvar clearcase-disable-tq clearcase-on-mswindows - "Set to T if the Emacs/cleartool interactions via tq are not working right.") - -(defun clearcase-ct-blocking-call (&rest cmd) - (clearcase-trace (format "clearcase-ct-blocking-call(%s)" cmd)) - (save-excursion - (setq clearcase-ct-return nil) - - (if clearcase-disable-tq - ;; Don't use tq: - ;; - (setq clearcase-ct-return (apply 'clearcase-ct-get-command-stdout - clearcase-cleartool-path cmd)) - - ;; Use tq: - ;; - (setq clearcase-ct-return nil) - (if (not clearcase-ct-tq) - (clearcase-ct-start-cleartool)) - (unwind-protect - (let ((command "")) - (mapcar - (function - (lambda (token) - ;; If the token has imbedded spaces and is not already quoted, - ;; add double quotes. - ;; - (setq command (concat command - " " - (clearcase-utl-quote-if-nec token))))) - cmd) - (tq-enqueue clearcase-ct-tq - (concat command "\n" - clearcase-ct-eotxn-cmd) ;; question - clearcase-ct-eotxn-response ;; regexp - nil ;; closure - 'clearcase-ct-callback) ;; function - (while (not clearcase-ct-return) - (clearcase-ct-accept-process-output (tq-process clearcase-ct-tq) - clearcase-ct-subproc-timeout))) - ;; Error signalled: - ;; - (while (tq-queue clearcase-ct-tq) - (tq-queue-pop clearcase-ct-tq))))) - (if (string-match "cleartool: Error:" clearcase-ct-return) - (error "cleartool process error %s: " - (substring clearcase-ct-return (match-end 0)))) - (clearcase-trace (format "command-result(%s)" clearcase-ct-return)) - clearcase-ct-return) - -(defun clearcase-ct-kill-tq () - (setq clearcase-ct-running nil) - (setq clearcase-ct-tq nil) - (process-send-eof (tq-process clearcase-ct-tq)) - (kill-process (tq-process clearcase-ct-tq))) - -(defun clearcase-ct-kill-buffer-hook () - - ;; NT Emacs - doesn't use tq. - ;; - (if (not clearcase-on-mswindows) - (let ((kill-buffer-hook nil)) - (if (and (boundp 'clearcase-ct-tq) - clearcase-ct-tq - (eq (current-buffer) (tq-buffer clearcase-ct-tq))) - (error "Don't kill TQ buffer %s, use `clearcase-ct-kill-tq'" (current-buffer)))))) - -(add-hook 'kill-buffer-hook 'clearcase-ct-kill-buffer-hook) - -;;}}} - -;;{{{ Invoking a command - -;; nyi Would be redundant if we didn't need it to invoke normal-diff-program - -(defun clearcase-do-command (okstatus command file &optional extra-args) - "Execute a version-control command, notifying user and checking for errors. -The command is successful if its exit status does not exceed OKSTATUS. -Output from COMMAND goes to buffer *clearcase*. The last argument of the command is -an optional list of EXTRA-ARGS." - (setq file (expand-file-name file)) - (if clearcase-command-messages - (message "Running %s on %s..." command file)) - (let ((camefrom (current-buffer)) - (pwd ) - (squeezed nil) - status) - (set-buffer (get-buffer-create "*clearcase*")) - (setq buffer-read-only nil) - (erase-buffer) - (set (make-local-variable 'clearcase-parent-buffer) camefrom) - (set (make-local-variable 'clearcase-parent-buffer-name) - (concat " from " (buffer-name camefrom))) - ;; This is so that command arguments typed in the *clearcase* buffer will - ;; have reasonable defaults. - ;; - (setq default-directory (file-name-directory file) - file (file-name-nondirectory file)) - - (mapcar - (function (lambda (s) - (and s - (not (zerop (length s))) - (setq squeezed - (append squeezed (list s)))))) - extra-args) - (setq squeezed (append squeezed (list file))) - (setq status (apply 'call-process command nil t nil squeezed)) - (goto-char (point-min)) - (clearcase-view-mode 0 camefrom) - (set-buffer-modified-p nil) ; XEmacs - fsf uses `not-modified' - (if (or (not (integerp status)) (< okstatus status)) - (progn - (clearcase-port-view-buffer-other-window "*clearcase*") - (shrink-window-if-larger-than-buffer) - (error "Running %s...FAILED (%s)" command - (if (integerp status) - (format "status %d" status) - status))) - (if clearcase-command-messages - (message "Running %s...OK" command))) - (set-buffer camefrom) - status)) - -;;}}} - -;;{{{ Viewtag management - -;;{{{ Started views - -(defun clearcase-viewtag-try-to-start-view (viewtag) - "If VIEW is not apparently already visible under viewroot, start it." - (if (not (member viewtag (clearcase-viewtag-started-viewtags))) - (clearcase-viewtag-start-view viewtag))) - -(defun clearcase-viewtag-started-viewtags-alist () - "Return an alist of views that are currently visible under the viewroot." - (mapcar - (function - (lambda (tag) - (list (concat tag "/")))) - (clearcase-viewtag-started-viewtags))) - -(defun clearcase-viewtag-started-viewtags () - "Return the list of viewtags already visible under the viewroot." - (let ((raw-list (if clearcase-on-mswindows - (directory-files clearcase-viewroot-drive) - (directory-files clearcase-viewroot)))) - (clearcase-utl-list-filter - (function (lambda (string) - ;; Exclude the ones that start with ".", - ;; and the ones that end with "@@". - ;; - (and (not (equal ?. (aref string 0))) - (not (string-match "@@$" string))))) - raw-list))) - -;; nyi: Makes sense on NT ? -;; Probably also want to run subst ? -;; Need a better high-level interface to start-view -;; -(defun clearcase-viewtag-start-view (viewtag) - "If VIEWTAG is in our cache of valid view names, start it." - (if (clearcase-viewtag-exists viewtag) - (progn - (message "Starting view server for %s..." viewtag) - (clearcase-ct-blocking-call "startview" viewtag) - (message "Starting view server for %s...done" viewtag)))) - -;;}}} - -;;{{{ All views - -;;{{{ Internals - -(defvar clearcase-viewtag-cache nil - "Oblist of all known viewtags.") - -(defvar clearcase-viewtag-dir-cache nil - "Oblist of all known viewtag dirs.") - -(defvar clearcase-viewtag-cache-timeout 1800 - "*Default timeout of all-viewtag cache, in seconds.") - -(defun clearcase-viewtag-schedule-cache-invalidation () - "Schedule the next invalidation of clearcase-viewtag-cache." - (run-at-time (format "%s sec" clearcase-viewtag-cache-timeout) - nil - (function (lambda (&rest ignore) - (setq clearcase-viewtag-cache nil))) - nil)) -;; Some primes: -;; -;; 1, -;; 2, -;; 3, -;; 7, -;; 17, -;; 31, -;; 61, -;; 127, -;; 257, -;; 509, -;; 1021, -;; 2053, - -(defun clearcase-viewtag-read-all-viewtags () - "Invoke ct+lsview to get all viewtags, and return an obarry containing them." - (message "Fetching view names...") - (let* ((default-directory "/") - (result (make-vector 1021 0)) - (raw-views-string (clearcase-ct-blocking-call "lsview" "-short")) - (view-list (clearcase-utl-split-string-at-char raw-views-string ?\n))) - (message "Fetching view names...done") - (mapcar (function (lambda (string) - (set (intern string result) t))) - view-list) - result)) - -(defun clearcase-viewtag-populate-caches () - (setq clearcase-viewtag-cache (clearcase-viewtag-read-all-viewtags)) - (let ((dir-cache (make-vector 1021 0))) - (mapatoms - (function (lambda (sym) - (set (intern (concat (symbol-name sym) "/") dir-cache) t))) - clearcase-viewtag-cache) - (setq clearcase-viewtag-dir-cache dir-cache)) - (clearcase-viewtag-schedule-cache-invalidation)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;}}} - -;; Exported interfaces - -;; This is for completion of viewtags. -;; -(defun clearcase-viewtag-all-viewtags-obarray () - "Return an obarray of all valid viewtags as of the last time we looke d." - (if (null clearcase-viewtag-cache) - (clearcase-viewtag-populate-caches)) - clearcase-viewtag-cache) - -;; This is for completion of viewtag dirs, like /view/my_view_name/ -;; The trailing slash is required for compatibility with other instances -;; of filename completion in Emacs. -;; -(defun clearcase-viewtag-all-viewtag-dirs-obarray () - "Return an obarray of all valid viewtag directory names as of the last time we looked." - (if (null clearcase-viewtag-dir-cache) - (clearcase-viewtag-populate-caches)) - clearcase-viewtag-dir-cache) - -(defun clearcase-viewtag-exists (viewtag) - (symbol-value (intern-soft viewtag (clearcase-viewtag-all-viewtags-obarray)))) - -;;}}} - -;;}}} - -;;{{{ Pathnames - -;;{{{ Pathnames: version-extended - -(defun clearcase-vxpath-p (path) - (or (string-match (concat clearcase-vxpath-glue "/") path) - (string-match (concat clearcase-vxpath-glue "\\\\") path))) - -(defun clearcase-vxpath-element-part (vxpath) - "Return the element part of version-extended PATH." - (if (string-match clearcase-vxpath-glue vxpath) - (substring vxpath 0 (match-beginning 0)) - vxpath)) - -(defun clearcase-vxpath-version-part (vxpath) - "Return the version part of version-extended PATH." - (if (string-match clearcase-vxpath-glue vxpath) - (substring vxpath (match-end 0)) - nil)) - -(defun clearcase-vxpath-branch (vxpath) - "Return the branch part of a version-extended path or of a version" - (if (clearcase-vxpath-p vxpath) - (clearcase-vxpath-cons-vxpath - (clearcase-vxpath-element-part vxpath) - (file-name-directory (clearcase-vxpath-version-part vxpath))) - (file-name-directory vxpath))) - -(defun clearcase-vxpath-version (vxpath) - "Return the numeric version part of a version-extended path or of a version" - (if (clearcase-vxpath-p vxpath) - (file-name-nondirectory (clearcase-vxpath-version-part vxpath)) - (file-name-nondirectory vxpath))) - -(defun clearcase-vxpath-cons-vxpath (file version &optional viewtag) - "Make a ClearCase version-extended pathname for ELEMENT's version VERSION. -If ELEMENT is actually a version-extended pathname, substitute VERSION for -the version included in ELEMENT. If VERSION is nil, remove the version-extended -pathname. - -If optional VIEWTAG is specified, make a view-relative pathname, possibly -replacing the existing view prefix." - (let* ((element (clearcase-vxpath-element-part file)) - (glue-fmt (if (and (> (length version) 0) - (= (aref version 0) ?/)) - (concat "%s" clearcase-vxpath-glue "%s") - (concat "%s" clearcase-vxpath-glue "/%s"))) - (relpath (clearcase-vrpath-tail element))) - (if viewtag - (setq element (concat clearcase-viewroot "/" viewtag (or relpath element)))) - (if version - (format glue-fmt element version) - element))) - -;; NYI: This should cache the predecessor version as a property -;; of the file. -;; -(defun clearcase-vxpath-of-predecessor (file) - "Compute the version-extended pathname of the predecessor version of FILE." - (if (not (equal 'version (clearcase-fprop-mtype file))) - (error "Not a clearcase version: %s" file)) - (let ((abs-file (expand-file-name file))) - (let ((ver (clearcase-utl-1st-line-of-string - (clearcase-ct-cleartool-cmd "describe" - "-pred" - "-short" - (clearcase-path-native abs-file))))) - (clearcase-path-canonicalise-slashes (concat - (clearcase-vxpath-element-part file) - clearcase-vxpath-glue - ver))))) - -(defun clearcase-vxpath-version-extend (file) - "Compute the version-extended pathname of FILE." - (if (not (equal 'version (clearcase-fprop-mtype file))) - (error "Not a clearcase version: %s" file)) - (let ((abs-file (expand-file-name file))) - (clearcase-path-canonicalise-slashes - (clearcase-utl-1st-line-of-string - (clearcase-ct-cleartool-cmd "describe" - "-fmt" - (concat "%En" - clearcase-vxpath-glue - "%Vn") - (clearcase-path-native abs-file)))))) - -(defun clearcase-vxpath-of-branch-base (file) - "Compute the version-extended pathname of the version at the branch base of FILE." - (let* ((file-version-path - (if (clearcase-fprop-checked-out file) - ;; If the file is checked-out, start with its predecessor version... - ;; - (clearcase-vxpath-version-extend (clearcase-vxpath-of-predecessor file)) - ;; ...otherwise start with the file's version. - ;; - (clearcase-vxpath-version-extend file))) - (file-version-number (string-to-int (clearcase-vxpath-version file-version-path))) - (branch (clearcase-vxpath-branch file-version-path))) - (let* ((base-number 0) - (base-version-path (format "%s%d" branch base-number))) - (while (and (not (clearcase-file-is-in-snapshot-p base-version-path)) - (not (file-exists-p base-version-path)) - (< base-number file-version-number)) - (setq base-number (1+ base-number)) - (setq base-version-path (format "%s%d" branch base-number))) - base-version-path))) - -(defun clearcase-vxpath-version-of-branch-base (file) - (clearcase-vxpath-version-part (clearcase-vxpath-of-branch-base file))) - -(defun clearcase-vxpath-get-version-in-buffer (vxpath) - "Return a buffer containing the version named by VXPATH. -Intended for use in snapshot views." - (let* ((temp-file (clearcase-vxpath-get-version-in-temp-file vxpath)) - (buffer (find-file-noselect temp-file t))) - - ;; XEmacs throws an error if you delete a read-only file - ;; - (if clearcase-xemacs-p - (if (not (file-writable-p temp-file)) - (set-file-modes temp-file (string-to-number "666" 8)))) - - (delete-file temp-file) - buffer)) - -(defun clearcase-vxpath-get-version-in-temp-file (vxpath) - "Return the name of a temporary file containing the version named by VXPATH. -Intended for use in snapshot views." - - (let ((temp-file (clearcase-utl-tempfile-name vxpath))) - (progn - (clearcase-ct-blocking-call "get" - "-to" - (clearcase-path-native temp-file) - (clearcase-path-native vxpath)) - temp-file))) - -;;}}} - -;;{{{ Pathnames: viewroot-relative - -;; nyi: make all this work with viewroot-drive-relative files too - -(defun clearcase-vrpath-p (path) - "Return whether PATH is viewroot-relative." - (string-match clearcase-vrpath-regexp path)) - -(defun clearcase-vrpath-head (vrpath) - "Given viewroot-relative PATH, return the prefix including the view-tag." - (if (string-match clearcase-vrpath-regexp vrpath) - (substring vrpath (match-end 0)))) - -(defun clearcase-vrpath-tail (vrpath) - "Given viewroot-relative PATH, return the suffix after the view-tag." - (if (string-match clearcase-vrpath-regexp vrpath) - (substring vrpath (match-end 0)))) - -(defun clearcase-vrpath-viewtag (vrpath) - "Given viewroot-relative PATH, return the view-tag." - (if (string-match clearcase-vrpath-regexp vrpath) - (substring vrpath (match-beginning 1) (match-end 1)))) - -;; Remove useless viewtags from a pathname. -;; e.g. if we're setviewed to view "VIEWTAG" -;; (clearcase-path-remove-useless-viewtags "/view/VIEWTAG/PATH") -;; ==> "PATH" -;; (clearcase-path-remove-useless-viewtags "/view/z/view/y/PATH") -;; ==> /view/y/"PATH" -;; -(defvar clearcase-multiple-viewroot-regexp - (concat "^" - clearcase-viewroot - clearcase-pname-sep-regexp - clearcase-non-pname-sep-regexp "+" - "\\(" - clearcase-viewroot - clearcase-pname-sep-regexp - "\\)" - )) - -(defun clearcase-path-remove-useless-viewtags (pathname) - ;; Try to avoid file-name-handler recursion here: - ;; - (let ((setview-root clearcase-setview-root)) - (if setview-root - ;; Append "/": - ;; - (setq setview-root (concat setview-root "/"))) - - (cond - - ((string-match clearcase-multiple-viewroot-regexp pathname) - (clearcase-path-remove-useless-viewtags (substring pathname (match-beginning 1)))) - - ((and setview-root - (string= setview-root "/")) - pathname) - - ;; If pathname has setview-root as a proper prefix, - ;; strip it off and recurse: - ;; - ((and setview-root - (< (length setview-root) (length pathname)) - (string= setview-root (substring pathname 0 (length setview-root)))) - (clearcase-path-remove-useless-viewtags (substring pathname (- (length setview-root) 1)))) - - (t - pathname)))) - -;;}}} - -;; Don't pass the "INPLACE" parameter to subst-char-in-string here since the -;; parameter is not necessarily a local variable (in some cases it is -;; buffer-file-name and replacing / with \ in it wreaks havoc). -;; -(defun clearcase-path-canonicalise-slashes (path) - (if (not clearcase-on-mswindows) - path - (subst-char-in-string ?\\ ?/ path))) - -(defun clearcase-path-canonical (path) - (if (not clearcase-on-mswindows) - path - (if clearcase-on-cygwin - (substring (shell-command-to-string (concat "cygpath -u '" path "'")) 0 -1) - (subst-char-in-string ?\\ ?/ path)))) - -(defun clearcase-path-native (path) - (if (not clearcase-on-mswindows) - path - (if clearcase-on-cygwin - (substring (shell-command-to-string (concat "cygpath -w " path)) 0 -1) - (subst-char-in-string ?/ ?\\ path)))) - -(defun clearcase-path-file-really-exists-p (filename) - "Test if a file really exists, when all file-name handlers are disabled." - (let ((inhibit-file-name-operation 'file-exists-p) - (inhibit-file-name-handlers (mapcar - (lambda (pair) - (cdr pair)) - file-name-handler-alist))) - (file-exists-p filename))) - -(defun clearcase-path-file-in-any-scopes (file scopes) - (let ((result nil) - (cursor scopes)) - (while (and (null result) - cursor) - (if (clearcase-path-file-in-scope file (car cursor)) - (setq result t)) - (setq cursor (cdr cursor))) - result)) - - -(defun clearcase-path-file-in-scope (file scope) - (assert (file-name-absolute-p file)) - (assert (file-name-absolute-p scope)) - - (or - ;; Pathnames are equal - ;; - (string= file scope) - - ;; scope-qua-dir is an ancestor of file (proper string prefix) - ;; - (let ((scope-as-dir (concat scope "/"))) - (string= scope-as-dir - (substring file 0 (length scope-as-dir)))))) - -;;}}} - -;;{{{ Mode-line - -(defun clearcase-mode-line-buffer-id (filename) - "Compute an abbreviated version string for the mode-line. -It will be in one of three forms: /main/NNN, or .../branchname/NNN, or DO-NAME" - - (if (clearcase-fprop-checked-out filename) - (if (clearcase-fprop-reserved filename) - "RESERVED" - "UNRESERVED") - (let ((ver-string (clearcase-fprop-version filename))) - (if (not (zerop (length ver-string))) - (let ((i (length ver-string)) - (slash-count 0)) - ;; Search back from the end to the second-last slash - ;; - (while (and (> i 0) - (< slash-count 2)) - (if (equal ?/ (aref ver-string (1- i))) - (setq slash-count (1+ slash-count))) - (setq i (1- i))) - (if (> i 0) - (concat "..." (substring ver-string i)) - (substring ver-string i))))))) - -;;}}} - -;;{{{ Minibuffer reading - -;;{{{ clearcase-read-version-name - -(defun clearcase-read-version-name (prompt file) - "Display PROMPT and read a version string for FILE in the minibuffer, -with completion if possible." - (let* ((insert-default-directory nil) - (predecessor (clearcase-fprop-predecessor-version file)) - (default-filename (clearcase-vxpath-cons-vxpath file predecessor)) - - ;; To get this to work it is necessary to make Emacs think - ;; we're completing with respect to "ELEMENT@@/" rather - ;; than "ELEMENT@@". Otherwise when we enter a version - ;; like "/main/NN", it thinks we entered an absolute path. - ;; So instead, we prompt the user to enter "main/..../NN" - ;; and add back the leading slash before returning. - ;; - (completing-dir (concat file "@@/"))) - (if (and (clearcase-file-is-in-mvfs-p file) (not clearcase-on-mswindows)) - ;; Completion only works in MVFS: - ;; - (concat "/" (read-file-name prompt - completing-dir - (substring predecessor 1) - ;;nil - t - (substring predecessor 1))) - (concat "/" (read-string prompt - (substring predecessor 1) - nil))))) - -;;}}} - -;;{{{ clearcase-read-label-name - -;; nyi: unused - -(defun clearcase-read-label-name (prompt) - "Read a label name." - - (let* ((string (clearcase-ct-cleartool-cmd "lstype" - "-kind" - "lbtype" - "-short")) - labels) - (mapcar (function (lambda (arg) - (if (string-match "(locked)" arg) - nil - (setq labels (cons (list arg) labels))))) - (clearcase-utl-split-string string "\n")) - (completing-read prompt labels nil t))) - -;;}}} - -;;}}} - -;;{{{ Directory-tree walking - -(defun clearcase-dir-all-files (func &rest args) - "Invoke FUNC f ARGS on each regular file f in default directory." - (let ((dir default-directory)) - (message "Scanning directory %s..." dir) - (mapcar (function (lambda (f) - (let ((dirf (expand-file-name f dir))) - (apply func dirf args)))) - (directory-files dir)) - (message "Scanning directory %s...done" dir))) - -(defun clearcase-file-tree-walk-internal (file func args quiet) - (if (not (file-directory-p file)) - (apply func file args) - (or quiet - (message "Traversing directory %s..." file)) - (let ((dir (file-name-as-directory file))) - (mapcar - (function - (lambda (f) (or - (string-equal f ".") - (string-equal f "..") - (member f clearcase-directory-exclusion-list) - (let ((dirf (concat dir f))) - (or - (file-symlink-p dirf) ;; Avoid possible loops - (clearcase-file-tree-walk-internal dirf func args quiet)))))) - (directory-files dir))))) -;; -(defun clearcase-file-tree-walk (func &rest args) - "Walk recursively through default directory. -Invoke FUNC f ARGS on each non-directory file f underneath it." - (clearcase-file-tree-walk-internal default-directory func args nil) - (message "Traversing directory %s...done" default-directory)) - -(defun clearcase-subdir-tree-walk (func &rest args) - "Walk recursively through default directory. -Invoke FUNC f ARGS on each subdirectory underneath it." - (clearcase-subdir-tree-walk-internal default-directory func args nil) - (message "Traversing directory %s...done" default-directory)) - -(defun clearcase-subdir-tree-walk-internal (file func args quiet) - (if (file-directory-p file) - (let ((dir (file-name-as-directory file))) - (apply func dir args) - (or quiet - (message "Traversing directory %s..." file)) - (mapcar - (function - (lambda (f) (or - (string-equal f ".") - (string-equal f "..") - (member f clearcase-directory-exclusion-list) - (let ((dirf (concat dir f))) - (or - (file-symlink-p dirf) ;; Avoid possible loops - (clearcase-subdir-tree-walk-internal dirf - func - args - quiet)))))) - (directory-files dir))))) - -;;}}} - -;;{{{ Buffer context - -;; nyi: it would be nice if we could restore fold context too, for folded files. - -;; Save a bit of the text around POSN in the current buffer, to help -;; us find the corresponding position again later. This works even -;; if all markers are destroyed or corrupted. -;; -(defun clearcase-position-context (posn) - (list posn - (buffer-size) - (buffer-substring posn - (min (point-max) (+ posn 100))))) - -;; Return the position of CONTEXT in the current buffer, or nil if we -;; couldn't find it. -;; -(defun clearcase-find-position-by-context (context) - (let ((context-string (nth 2 context))) - (if (equal "" context-string) - (point-max) - (save-excursion - (let ((diff (- (nth 1 context) (buffer-size)))) - (if (< diff 0) (setq diff (- diff))) - (goto-char (nth 0 context)) - (if (or (search-forward context-string nil t) - ;; Can't use search-backward since the match may continue - ;; after point. - ;; - (progn (goto-char (- (point) diff (length context-string))) - ;; goto-char doesn't signal an error at - ;; beginning of buffer like backward-char would. - ;; - (search-forward context-string nil t))) - ;; to beginning of OSTRING - ;; - (- (point) (length context-string)))))))) - -;;}}} - -;;{{{ Synchronizing buffers with disk - -(defun clearcase-sync-after-file-updated-from-vob (file) - ;; Do what is needed after a file in a snapshot is updated or a checkout is - ;; cancelled. - - ;; "ct+update" will not always make the file readonly, if, for - ;; example, its contents didn't actually change. But we'd like - ;; update to result in a readonly file, so force it here. - ;; - (clearcase-utl-make-unwriteable file) - - (or - ;; If this returns true, there was a buffer visiting the file and it it - ;; flushed fprops... - ;; - (clearcase-sync-from-disk-if-needed file) - - ;; ...otherwise, just sync this other state: - ;; - (progn - (clearcase-fprop-unstore-properties file) - (dired-relist-file file)))) - -(defun clearcase-sync-from-disk (file &optional no-confirm) - - (clearcase-fprop-unstore-properties file) - ;; If the given file is in any buffer, revert it. - ;; - (let ((buffer (find-buffer-visiting file))) - (if buffer - (save-excursion - (set-buffer buffer) - (clearcase-buffer-revert no-confirm) - (clearcase-fprop-get-properties file) - - ;; Make sure the mode-line gets updated. - ;; - (setq clearcase-mode - (concat " ClearCase:" - (clearcase-mode-line-buffer-id file))) - (force-mode-line-update)))) - - ;; Update any Dired Mode buffers that list this file. - ;; - (dired-relist-file file) - - ;; If the file was a directory, update any dired-buffer for - ;; that directory. - ;; - (mapcar (function (lambda (buffer) - (save-excursion - (set-buffer buffer) - (revert-buffer)))) - (dired-buffers-for-dir file))) - -(defun clearcase-sync-from-disk-if-needed (file) - - ;; If the buffer on FILE is out of sync with its file, synch it. Returns t if - ;; clearcase-sync-from-disk is called. - - (let ((buffer (find-buffer-visiting file))) - (if (and buffer - ;; Buffer can be out of sync in two ways: - ;; (a) Buffer is modified (hasn't been written) - ;; (b) Buffer is recording a different modtime to what the file has. - ;; This is what happens when the file is updated by another - ;; process. - ;; (c) Buffer and file differ in their writeability. - ;; - (or (buffer-modified-p buffer) - (not (verify-visited-file-modtime buffer)) - (eq (file-writable-p file) - (with-current-buffer buffer buffer-read-only)))) - (progn - (clearcase-sync-from-disk file - ;; Only confirm for modified buffers. - ;; - (not (buffer-modified-p buffer))) - t) - nil))) - - -(defun clearcase-sync-to-disk (&optional not-urgent) - - ;; Make sure the current buffer and its working file are in sync - ;; NOT-URGENT means it is ok to continue if the user says not to save. - ;; - (if (buffer-modified-p) - (if (or clearcase-suppress-confirm - (y-or-n-p (format "Buffer %s modified; save it? " - (buffer-name)))) - (save-buffer) - (if not-urgent - nil - (error "Aborted"))))) - - -(defun clearcase-buffer-revert (&optional no-confirm) - ;; Should never call for Dired buffers - ;; - (assert (not (eq major-mode 'dired-mode))) - - ;; Revert buffer, try to keep point and mark where user expects them in spite - ;; of changes because of expanded version-control key words. This is quite - ;; important since otherwise typeahead won't work as expected. - ;; - (widen) - (let ((point-context (clearcase-position-context (point))) - - ;; Use clearcase-utl-mark-marker to avoid confusion in transient-mark-mode. - ;; XEmacs - mark-marker t, FSF Emacs - mark-marker. - ;; - (mark-context (if (eq (marker-buffer (clearcase-utl-mark-marker)) - (current-buffer)) - (clearcase-position-context (clearcase-utl-mark-marker)))) - (camefrom (current-buffer))) - - ;; nyi: Should we run font-lock ? - ;; Want to avoid re-doing a buffer that is already correct, such as on - ;; check-in/check-out. - ;; For now do-nothing. - - ;; The actual revisit. - ;; For some reason, revert-buffer doesn't recompute whether View Minor Mode - ;; should be on, so turn it off and then turn it on if necessary. - ;; - ;; nyi: Perhaps we should re-find-file ? - ;; - (or clearcase-xemacs-p - (if (fboundp 'view-mode) - (view-mode 0))) - (revert-buffer t no-confirm t) - (or clearcase-xemacs-p - (if (and (boundp 'view-read-only) - view-read-only - buffer-read-only) - (view-mode 1))) - - ;; Restore point and mark. - ;; - (let ((new-point (clearcase-find-position-by-context point-context))) - (if new-point - (goto-char new-point)) - (if mark-context - (let ((new-mark (clearcase-find-position-by-context mark-context))) - (if new-mark - (set-mark new-mark)))) - - ;; Restore a semblance of folded state. - ;; - (if (and (boundp 'folded-file) - folded-file) - (progn - (folding-open-buffer) - (folding-whole-buffer) - (if new-point - (folding-goto-char new-point))))))) - -;;}}} - -;;{{{ Utilities - -;;{{{ Displaying content in special buffers - -(defun clearcase-utl-populate-and-view-buffer (buffer - args - content-generating-func) - "Empty BUFFER, and populate it by applying to ARGS the CONTENT-GENERATING-FUNC, -and display in a separate window." - - (clearcase-utl-edit-and-view-buffer - buffer - (list args) - (function - (lambda (args) - (erase-buffer) - (apply content-generating-func args))))) - -(defun clearcase-utl-edit-and-view-buffer (buffer - args - content-editing-func) - "Empty BUFFER, and edit it by applying to ARGS the CONTENT-EDITING-FUNC, -and display in a separate window." - - (let ( ;; Create the buffer if necessary. - ;; - (buf (get-buffer-create buffer)) - - ;; Record where we came from. - ;; - (camefrom (current-buffer))) - - (set-buffer buf) - (clearcase-view-mode 0 camefrom) - - ;; Edit the buffer. - ;; - (apply content-editing-func args) - - ;; Display the buffer. - ;; - (clearcase-port-view-buffer-other-window buf) - (goto-char 0) - (set-buffer-modified-p nil) ; XEmacs - fsf uses `not-modified' - (shrink-window-if-larger-than-buffer))) - -;;}}} - -;;{{{ Temporary files - -(defvar clearcase-tempfiles nil) -(defun clearcase-utl-tempfile-name (&optional vxpath) - (let ((ext "")) - (and vxpath - (save-match-data - (if (string-match "\\(\\.[^.]+\\)@@" vxpath) - (setq ext (match-string 1 vxpath))))) - (let ((filename (concat - (make-temp-name (clearcase-path-canonical - ;; Use TEMP e.v. if set. - ;; - (concat (or (getenv "TEMP") "/tmp") - "/clearcase-"))) - ext))) - ;; Store its name for later cleanup. - ;; - (setq clearcase-tempfiles (cons filename clearcase-tempfiles)) - filename))) - -(defun clearcase-utl-clean-tempfiles () - (mapcar (function - (lambda (tempfile) - (if (file-exists-p tempfile) - (condition-case nil - (delete-file tempfile) - (error nil))))) - clearcase-tempfiles) - (setq clearcase-tempfiles nil)) - -;;}}} - -(defun clearcase-utl-touch-file (file) - "Attempt to update the modtime of FILE. Return t if it worked." - (zerop - ;; Silently fail if there is no "touch" command available. Couldn't find a - ;; convenient way to update a file's modtime in ELisp. - ;; - (condition-case nil - (prog1 - (shell-command (concat "touch " file)) - (message "")) - (error nil)))) - -(defun clearcase-utl-filetimes-close (filetime1 filetime2 tolerance) - "Test if FILETIME1 and FILETIME2 are within TOLERANCE of each other." - ;; nyi: To do this correctly we need to know MAXINT. - ;; For now this is correct enough since we only use this as a guideline to - ;; avoid generating a diff. - ;; - (if (equal (first filetime1) (first filetime2)) - (< (abs (- (second filetime1) (second filetime2))) tolerance) - nil)) - -(defun clearcase-utl-emacs-date-to-clearcase-date (s) - (concat - (substring s 20) ;; yyyy - (int-to-string (clearcase-utl-month-unparse (substring s 4 7))) ;; mm - (substring s 8 10) ;; dd - "." - (substring s 11 13) ;; hh - (substring s 14 16) ;; mm - (substring s 17 19))) ;; ss - -(defun clearcase-utl-month-unparse (s) - (cond - ((string= s "Jan") 1) - ((string= s "Feb") 2) - ((string= s "Mar") 3) - ((string= s "Apr") 4) - ((string= s "May") 5) - ((string= s "Jun") 6) - ((string= s "Jul") 7) - ((string= s "Aug") 8) - ((string= s "Sep") 9) - ((string= s "Oct") 10) - ((string= s "Nov") 11) - ((string= s "Dec") 12))) - -(defun clearcase-utl-strip-trailing-slashes (name) - (let* ((len (length name))) - (while (and (> len 1) - (or (equal ?/ (aref name (1- len))) - (equal ?\\ (aref name (1- len))))) - (setq len (1- len))) - (substring name 0 len))) - -(defun clearcase-utl-file-size (file) - (nth 7 (file-attributes file))) -(defun clearcase-utl-file-atime (file) - (nth 4 (file-attributes file))) -(defun clearcase-utl-file-mtime (file) - (nth 5 (file-attributes file))) -(defun clearcase-utl-file-ctime (file) - (nth 6 (file-attributes file))) - -(defun clearcase-utl-kill-view-buffer () - (interactive) - (let ((buf (current-buffer))) - (delete-windows-on buf) - (kill-buffer buf))) - -(defun clearcase-utl-escape-double-quotes (s) - "Escape any double quotes in string S" - (mapconcat (function (lambda (char) - (if (equal ?\" char) - (string ?\\ char) - (string char)))) - s - "")) - -(defun clearcase-utl-escape-backslashes (s) - "Double any backslashes in string S" - (mapconcat (function (lambda (char) - (if (equal ?\\ char) - "\\\\" - (string char)))) - s - "")) - -(defun clearcase-utl-quote-if-nec (token) - "If TOKEN contains whitespace and is not already quoted, -wrap it in double quotes." - (if (and (string-match "[ \t]" token) - (not (equal ?\" (aref token 0))) - (not (equal ?\' (aref token 0)))) - (concat "\"" token "\"") - token)) - -(defun clearcase-utl-or-func (&rest args) - "A version of `or' that can be applied to a list." - (let ((result nil) - (cursor args)) - (while (and (null result) - cursor) - (if (car cursor) - (setq result t)) - (setq cursor (cdr cursor))) - result)) - -(defun clearcase-utl-any (predicate list) - "Returns t if PREDICATE is satisfied by any element in LIST." - (let ((result nil) - (cursor list)) - (while (and (null result) - cursor) - (if (funcall predicate (car cursor)) - (setq result t)) - (setq cursor (cdr cursor))) - result)) - -(defun clearcase-utl-every (predicate list) - "Returns t if PREDICATE is satisfied by every element in LIST." - (let ((result t) - (cursor list)) - (while (and result - cursor) - (if (not (funcall predicate (car cursor))) - (setq result nil)) - (setq cursor (cdr cursor))) - result)) - -(defun clearcase-utl-list-filter (predicate list) - "Map PREDICATE over each element of LIST, and return a list of the elements -that mapped to non-nil." - (let ((result '()) - (cursor list)) - (while (not (null cursor)) - (let ((elt (car cursor))) - (if (funcall predicate elt) - (setq result (cons elt result))) - (setq cursor (cdr cursor)))) - (nreverse result))) - -(defun clearcase-utl-elts-are-eq (l) - "Test if all elements of LIST are eq." - (if (null l) - t - (let ((head (car l)) - (answer t)) - (mapcar (function (lambda (elt) - (if (not (eq elt head)) - (setq answer nil)))) - (cdr l)) - answer))) - -;; FSF Emacs - doesn't like parameters on mark-marker. -;; -(defun clearcase-utl-mark-marker () - (if clearcase-xemacs-p - (mark-marker t) - (mark-marker))) - -(defun clearcase-utl-syslog (buf value) - (save-excursion - (let ((tmpbuf (get-buffer buf))) - (if (bufferp tmpbuf) - (progn - (set-buffer buf) - (goto-char (point-max)) - (insert (format "%s\n" value))))))) - -;; Extract the first line of a string. -;; -(defun clearcase-utl-1st-line-of-string (s) - (let ((newline ?\n) - (len (length s)) - (i 0)) - (while (and (< i len) - (not (eq newline - (aref s i)))) - (setq i (1+ i))) - (substring s 0 i))) - -(defun clearcase-utl-split-string (str pat &optional indir suffix) - (let ((ret nil) - (start 0) - (last (length str))) - (while (< start last) - (if (string-match pat str start) - (progn - (let ((tmp (substring str start (match-beginning 0)))) - (if suffix (setq tmp (concat tmp suffix))) - (setq ret (cons (if indir (cons tmp nil) - tmp) - ret))) - (setq start (match-end 0))) - (setq start last) - (setq ret (cons (substring str start) ret)))) - (nreverse ret))) - -(defun clearcase-utl-split-string-at-char (str char) - (let ((ret nil) - (i 0) - (eos (length str))) - (while (< i eos) - ;; Collect next token - ;; - (let ((token-begin i)) - ;; Find the end - ;; - (while (and (< i eos) - (not (eq char (aref str i)))) - (setq i (1+ i))) - - (setq ret (cons (substring str token-begin i) - ret)) - (setq i (1+ i)))) - (nreverse ret))) - - -(defun clearcase-utl-add-env (env var) - (catch 'return - (let ((a env) - (vname (substring var 0 - (and (string-match "=" var) - (match-end 0))))) - (let ((vnl (length vname))) - (while a - (if (and (> (length (car a)) vnl) - (string= (substring (car a) 0 vnl) - vname)) - (throw 'return env)) - (setq a (cdr a))) - (cons var env))))) - - -(defun clearcase-utl-augment-env-from-view-config-spec (old-env tag &optional add-ons) - (let ((newenv nil) - (cc-env (clearcase-misc-extract-evs-from-config-spe tag))) - - ;; 1. Add-on bindings at the front: - ;; - (while add-ons - (setq newenv (clearcase-utl-add-env newenv (car add-ons))) - (setq add-ons (cdr add-ons))) - - ;; 2. Then bindings defined in the config-spec: - ;; - (while cc-env - (setq newenv (clearcase-utl-add-env newenv (car cc-env))) - (setq cc-env (cdr cc-env))) - - ;; 3. Lastly bindings that were in the old environment. - ;; - (while old-env - (setq newenv (clearcase-utl-add-env newenv (car old-env))) - (setq old-env (cdr old-env))) - newenv)) - -(defun clearcase-utl-make-writeable (file) - ;; Equivalent to chmod u+w - ;; - (set-file-modes file - (logior #o0200 (file-modes file)))) - -(defun clearcase-utl-make-unwriteable (file) - ;; Equivalent to chmod u-w - ;; - (set-file-modes file - (logand #o7577 (file-modes file)))) - -;;}}} - -;;}}} - -;;{{{ Menus - -;; Predicate to determine if ClearCase menu items are relevant. -;; nyi" this should disappear -;; -(defun clearcase-buffer-contains-version-p () - "Return true if the current buffer contains a ClearCase file or directory." - (let ((object-name (if (eq major-mode 'dired-mode) - default-directory - buffer-file-name))) - (clearcase-fprop-file-is-version-p object-name))) - -;;{{{ clearcase-mode menu - -;;{{{ The contents - -;; This version of the menu will hide rather than grey out inapplicable entries. -;; -(defvar clearcase-menu-contents-minimised - (list "ClearCase" - - ["Checkin" clearcase-checkin-current-buffer - :keys nil - :visible (clearcase-file-ok-to-checkin buffer-file-name)] - - ["Edit checkout comment" clearcase-edit-checkout-comment-current-buffer - :keys nil - :visible (clearcase-file-ok-to-checkin buffer-file-name)] - - ["Checkout" clearcase-checkout-current-buffer - :keys nil - :visible (clearcase-file-ok-to-checkout buffer-file-name)] - - ["Hijack" clearcase-hijack-current-buffer - :keys nil - :visible (clearcase-file-ok-to-hijack buffer-file-name)] - - ["Unhijack" clearcase-unhijack-current-buffer - :keys nil - :visible (clearcase-file-ok-to-unhijack buffer-file-name)] - - ["Uncheckout" clearcase-uncheckout-current-buffer - :visible (clearcase-file-ok-to-uncheckout buffer-file-name)] - - ["Find checkouts" clearcase-find-checkouts-in-current-view t] - - ["Make element" clearcase-mkelem-current-buffer - :visible (clearcase-file-ok-to-mkelem buffer-file-name)] - - "---------------------------------" - ["Describe version" clearcase-describe-current-buffer - :visible (clearcase-buffer-contains-version-p)] - - ["Describe file" clearcase-describe-current-buffer - :visible (not (clearcase-buffer-contains-version-p))] - - ["Annotate version" clearcase-annotate-current-buffer - :visible (clearcase-buffer-contains-version-p)] - - ["Show config-spec rule" clearcase-what-rule-current-buffer - :visible (clearcase-buffer-contains-version-p)] - - ;; nyi: enable this also when setviewed ? - ;; - ["Edit config-spec" clearcase-edcs-edit t] - - "---------------------------------" - (list "Compare (Emacs)..." - ["Compare with predecessor" clearcase-ediff-pred-current-buffer - :keys nil - :visible (clearcase-buffer-contains-version-p)] - ["Compare with branch base" clearcase-ediff-branch-base-current-buffer - :keys nil - :visible (clearcase-buffer-contains-version-p)] - ["Compare with named version" clearcase-ediff-named-version-current-buffer - :keys nil - :visible (clearcase-buffer-contains-version-p)]) - (list "Compare (GUI)..." - ["Compare with predecessor" clearcase-gui-diff-pred-current-buffer - :keys nil - :visible (clearcase-buffer-contains-version-p)] - ["Compare with branch base" clearcase-gui-diff-branch-base-current-buffer - :keys nil - :visible (clearcase-buffer-contains-version-p)] - ["Compare with named version" clearcase-gui-diff-named-version-current-buffer - :keys nil - :visible (clearcase-buffer-contains-version-p)]) - (list "Compare (diff)..." - ["Compare with predecessor" clearcase-diff-pred-current-buffer - :keys nil - :visible (clearcase-buffer-contains-version-p)] - ["Compare with branch base" clearcase-diff-branch-base-current-buffer - :keys nil - :visible (clearcase-buffer-contains-version-p)] - ["Compare with named version" clearcase-diff-named-version-current-buffer - :keys nil - :visible (clearcase-buffer-contains-version-p)]) - "---------------------------------" - ["Browse versions (dired)" clearcase-browse-vtree-current-buffer - :visible (clearcase-file-ok-to-browse buffer-file-name)] - ["Vtree browser GUI" clearcase-gui-vtree-browser-current-buffer - :keys nil - :visible (clearcase-buffer-contains-version-p)] - "---------------------------------" - (list "Update snapshot..." - ["Update view" clearcase-update-view - :keys nil - :visible (and (clearcase-file-is-in-view-p default-directory) - (not (clearcase-file-is-in-mvfs-p default-directory)))] - ["Update directory" clearcase-update-default-directory - :keys nil - :visible (and (clearcase-file-is-in-view-p default-directory) - (not (clearcase-file-is-in-mvfs-p default-directory)))] - ["Update this file" clearcase-update-current-buffer - :keys nil - :visible (and (clearcase-file-ok-to-checkout buffer-file-name) - (not (clearcase-file-is-in-mvfs-p buffer-file-name)))] - ) - "---------------------------------" - (list "Element history..." - ["Element history (full)" clearcase-list-history-current-buffer - :keys nil - :visible (clearcase-buffer-contains-version-p)] - ["Element history (branch)" clearcase-list-history-current-buffer - :keys nil - :visible (clearcase-buffer-contains-version-p)] - ["Element history (me)" clearcase-list-history-current-buffer - :keys nil - :visible (clearcase-buffer-contains-version-p)]) - "---------------------------------" - ["Show current activity" clearcase-ucm-describe-current-activity - :keys nil - :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))] - ["Make activity" clearcase-ucm-mkact-current-dir - :keys nil - :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))] - ["Set activity..." clearcase-ucm-set-activity-current-dir - :keys nil - :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))] - ["Set NO activity" clearcase-ucm-set-activity-none-current-dir - :keys nil - :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))] - ["Rebase this stream" clearcase-gui-rebase - :keys nil - :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))] - ["Deliver from this stream" clearcase-gui-deliver - :keys nil - :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))] - "---------------------------------" - (list "ClearCase GUI" - ["ClearCase Explorer" clearcase-gui-clearexplorer - :keys nil - :visible clearcase-on-mswindows] - ["Project Explorer" clearcase-gui-project-explorer - :keys nil] - ["Merge Manager" clearcase-gui-merge-manager - :keys nil] - ["Snapshot View Updater" clearcase-gui-snapshot-view-updater - :keys nil]) - "---------------------------------" - - ;; nyi: - ;; Enable this when current buffer is on VOB. - ;; - ["Make branch type" clearcase-mkbrtype - :keys nil] - - "---------------------------------" - ["Report Bug in ClearCase Mode" clearcase-submit-bug-report - :keys nil] - - ["Dump internals" clearcase-dump - :keys nil - :visible (or (equal "rwhitby" (user-login-name)) - (equal "esler" (user-login-name)))] - - ["Flush caches" clearcase-flush-caches - :keys nil - :visible (or (equal "rwhitby" (user-login-name)) - (equal "esler" (user-login-name)))] - - "---------------------------------" - ["Customize..." (customize-group 'clearcase) - :keys nil])) - -(defvar clearcase-menu-contents - (list "ClearCase" - - ["Checkin" clearcase-checkin-current-buffer - :keys nil - :active (clearcase-file-ok-to-checkin buffer-file-name)] - - ["Edit checkout comment" clearcase-edit-checkout-comment-current-buffer - :keys nil - :active (clearcase-file-ok-to-checkin buffer-file-name)] - - ["Checkout" clearcase-checkout-current-buffer - :keys nil - :active (clearcase-file-ok-to-checkout buffer-file-name)] - - ["Hijack" clearcase-hijack-current-buffer - :keys nil - :active (clearcase-file-ok-to-hijack buffer-file-name)] - - ["Unhijack" clearcase-unhijack-current-buffer - :keys nil - :active (clearcase-file-ok-to-unhijack buffer-file-name)] - - ["Uncheckout" clearcase-uncheckout-current-buffer - :active (clearcase-file-ok-to-uncheckout buffer-file-name)] - - ["Make element" clearcase-mkelem-current-buffer - :active (clearcase-file-ok-to-mkelem buffer-file-name)] - - "---------------------------------" - ["Describe version" clearcase-describe-current-buffer - :active (clearcase-buffer-contains-version-p)] - - ["Describe file" clearcase-describe-current-buffer - :active (not (clearcase-buffer-contains-version-p))] - - ["Annotate version" clearcase-annotate-current-buffer - :keys nil - :active (clearcase-buffer-contains-version-p)] - - ["Show config-spec rule" clearcase-what-rule-current-buffer - :active (clearcase-buffer-contains-version-p)] - - ;; nyi: enable this also when setviewed ? - ;; - ["Edit config-spec" clearcase-edcs-edit t] - - "---------------------------------" - (list "Compare (Emacs)..." - ["Compare with predecessor" clearcase-ediff-pred-current-buffer - :keys nil - :active (clearcase-buffer-contains-version-p)] - ["Compare with branch base" clearcase-ediff-branch-base-current-buffer - :keys nil - :active (clearcase-buffer-contains-version-p)] - ["Compare with named version" clearcase-ediff-named-version-current-buffer - :keys nil - :active (clearcase-buffer-contains-version-p)]) - (list "Compare (GUI)..." - ["Compare with predecessor" clearcase-gui-diff-pred-current-buffer - :keys nil - :active (clearcase-buffer-contains-version-p)] - ["Compare with branch base" clearcase-gui-diff-branch-base-current-buffer - :keys nil - :active (clearcase-buffer-contains-version-p)] - ["Compare with named version" clearcase-gui-diff-named-version-current-buffer - :keys nil - :active (clearcase-buffer-contains-version-p)]) - (list "Compare (diff)..." - ["Compare with predecessor" clearcase-diff-pred-current-buffer - :keys nil - :active (clearcase-buffer-contains-version-p)] - ["Compare with branch base" clearcase-diff-branch-base-current-buffer - :keys nil - :active (clearcase-buffer-contains-version-p)] - ["Compare with named version" clearcase-diff-named-version-current-buffer - :keys nil - :active (clearcase-buffer-contains-version-p)]) - "---------------------------------" - ["Browse versions (dired)" clearcase-browse-vtree-current-buffer - :active (clearcase-file-ok-to-browse buffer-file-name)] - ["Vtree browser GUI" clearcase-gui-vtree-browser-current-buffer - :keys nil - :active (clearcase-buffer-contains-version-p)] - "---------------------------------" - (list "Update snapshot..." - ["Update view" clearcase-update-view - :keys nil - :active (and (clearcase-file-is-in-view-p default-directory) - (not (clearcase-file-is-in-mvfs-p default-directory)))] - ["Update directory" clearcase-update-default-directory - :keys nil - :active (and (clearcase-file-is-in-view-p default-directory) - (not (clearcase-file-is-in-mvfs-p default-directory)))] - ["Update this file" clearcase-update-current-buffer - :keys nil - :active (and (clearcase-file-ok-to-checkout buffer-file-name) - (not (clearcase-file-is-in-mvfs-p buffer-file-name)))] - ) - "---------------------------------" - (list "Element history..." - ["Element history (full)" clearcase-list-history-current-buffer - :keys nil - :active (clearcase-buffer-contains-version-p)] - ["Element history (branch)" clearcase-list-history-current-buffer - :keys nil - :active (clearcase-buffer-contains-version-p)] - ["Element history (me)" clearcase-list-history-current-buffer - :keys nil - :active (clearcase-buffer-contains-version-p)]) - "---------------------------------" - ["Show current activity" clearcase-ucm-describe-current-activity - :keys nil - :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))] - ["Make activity" clearcase-ucm-mkact-current-dir - :keys nil - :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))] - ["Set activity..." clearcase-ucm-set-activity-current-dir - :keys nil - :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))] - ["Set NO activity" clearcase-ucm-set-activity-none-current-dir - :keys nil - :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))] - ["Rebase this stream" clearcase-gui-rebase - :keys nil - :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))] - ["Deliver from this stream" clearcase-gui-deliver - :keys nil - :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))] - "---------------------------------" - (list "ClearCase GUI" - ["ClearCase Explorer" clearcase-gui-clearexplorer - :keys nil - :active clearcase-on-mswindows] - ["Project Explorer" clearcase-gui-project-explorer - :keys nil] - ["Merge Manager" clearcase-gui-merge-manager - :keys nil] - ["Snapshot View Updater" clearcase-gui-snapshot-view-updater - :keys nil]) - "---------------------------------" - - ;; nyi: - ;; Enable this when current buffer is on VOB. - ;; - ["Make branch type" clearcase-mkbrtype - :keys nil] - - "---------------------------------" - ["Report Bug in ClearCase Mode" clearcase-submit-bug-report - :keys nil] - - ["Dump internals" clearcase-dump - :keys nil - :active (or (equal "rwhitby" (user-login-name)) - (equal "esler" (user-login-name)))] - - ["Flush caches" clearcase-flush-caches - :keys nil - :active (or (equal "rwhitby" (user-login-name)) - (equal "esler" (user-login-name)))] - - "---------------------------------" - ["Customize..." (customize-group 'clearcase) - :keys nil])) - -(if (and clearcase-minimise-menus - (not clearcase-xemacs-p)) - (setq clearcase-menu-contents clearcase-menu-contents-minimised)) - -;;}}}1 - -(if (>= emacs-major-version '20) - (progn - ;; Define the menu - ;; - (easy-menu-define - clearcase-menu - (list clearcase-mode-map) - "ClearCase menu" - clearcase-menu-contents) - - (or clearcase-xemacs-p - (add-to-list 'menu-bar-final-items 'ClearCase)))) - -;;}}} - -;;{{{ clearcase-dired-mode menu - -;;{{{ Related functions - -;; nyi: this probably gets run for each menu element. -;; For better efficiency, look into using a one-pass ":filter" -;; to construct this menu dynamically. - -(defun clearcase-dired-mark-count () - (let ((old-point (point)) - (count 0)) - (goto-char (point-min)) - (while (re-search-forward - (concat "^" (regexp-quote (char-to-string - dired-marker-char))) nil t) - (setq count (1+ count))) - (goto-char old-point) - count)) - -(defun clearcase-dired-current-ok-to-checkin () - (let ((file (dired-get-filename nil t))) - (and file - (clearcase-file-ok-to-checkin file)))) - -(defun clearcase-dired-current-ok-to-checkout () - (let ((file (dired-get-filename nil t))) - (and file - (clearcase-file-ok-to-checkout file)))) - -(defun clearcase-dired-current-ok-to-uncheckout () - (let ((file (dired-get-filename nil t))) - (and file - (clearcase-file-ok-to-uncheckout file)))) - -(defun clearcase-dired-current-ok-to-hijack () - (let ((file (dired-get-filename nil t))) - (and file - (clearcase-file-ok-to-hijack file)))) - -(defun clearcase-dired-current-ok-to-unhijack () - (let ((file (dired-get-filename nil t))) - (and file - (clearcase-file-ok-to-unhijack file)))) - -(defun clearcase-dired-current-ok-to-mkelem () - (let ((file (dired-get-filename nil t))) - (and file - (clearcase-file-ok-to-mkelem file)))) - -(defun clearcase-dired-current-ok-to-browse () - (let ((file (dired-get-filename nil t))) - (clearcase-file-ok-to-browse file))) - -(defvar clearcase-dired-max-marked-files-to-check 5 - "The maximum number of marked files in a Dired buffer when constructing -the ClearCase menu.") - -;; nyi: speed these up by stopping check when a non-qualifying file is found -;; Better: -;; - hook the menu constuction and figure out what ops apply -;; - hook mark/unmark/move cursor - -(defun clearcase-dired-marked-ok-to-checkin () - (let ((files (dired-get-marked-files))) - (or (> (length files) clearcase-dired-max-marked-files-to-check) - (clearcase-utl-every (function clearcase-file-ok-to-checkin) - files)))) - -(defun clearcase-dired-marked-ok-to-checkout () - (let ((files (dired-get-marked-files))) - (or (> (length files) clearcase-dired-max-marked-files-to-check) - (clearcase-utl-every (function clearcase-file-ok-to-checkout) - files)))) - -(defun clearcase-dired-marked-ok-to-uncheckout () - (let ((files (dired-get-marked-files))) - (or (> (length files) clearcase-dired-max-marked-files-to-check) - (clearcase-utl-every (function clearcase-file-ok-to-uncheckout) - files)))) - -(defun clearcase-dired-marked-ok-to-hijack () - (let ((files (dired-get-marked-files))) - (or (> (length files) clearcase-dired-max-marked-files-to-check) - (clearcase-utl-every (function clearcase-file-ok-to-hijack) - files)))) - -(defun clearcase-dired-marked-ok-to-unhijack () - (let ((files (dired-get-marked-files))) - (or (> (length files) clearcase-dired-max-marked-files-to-check) - (clearcase-utl-every (function clearcase-file-ok-to-unhijack) - files)))) - -(defun clearcase-dired-marked-ok-to-mkelem () - (let ((files (dired-get-marked-files))) - (or (> (length files) clearcase-dired-max-marked-files-to-check) - (clearcase-utl-every (function clearcase-file-ok-to-mkelem) - files)))) - -(defun clearcase-dired-current-dir-ok-to-checkin () - (let ((dir (dired-current-directory))) - (clearcase-file-ok-to-checkin dir))) - -(defun clearcase-dired-current-dir-ok-to-checkout () - (let ((dir (dired-current-directory))) - (clearcase-file-ok-to-checkout dir))) - -(defun clearcase-dired-current-dir-ok-to-uncheckout () - (let ((dir (dired-current-directory))) - (clearcase-file-ok-to-uncheckout dir))) - -;;}}} - -;;{{{ Contents - -;; This version of the menu will hide rather than grey out inapplicable entries. -;; -(defvar clearcase-dired-menu-contents-minimised - (list "ClearCase" - - ;; Current file - ;; - ["Checkin file" clearcase-checkin-dired-files - :keys nil - :visible (and (< (clearcase-dired-mark-count) 2) - (clearcase-dired-current-ok-to-checkin))] - - ["Edit checkout comment" clearcase-edit-checkout-comment-dired-file - :keys nil - :visible (and (< (clearcase-dired-mark-count) 2) - (clearcase-dired-current-ok-to-checkin))] - - ["Checkout file" clearcase-checkout-dired-files - :keys nil - :visible (and (< (clearcase-dired-mark-count) 2) - (clearcase-dired-current-ok-to-checkout))] - - ["Uncheckout file" clearcase-uncheckout-dired-files - :keys nil - :visible (and (< (clearcase-dired-mark-count) 2) - (clearcase-dired-current-ok-to-uncheckout))] - - ["Hijack file" clearcase-hijack-dired-files - :keys nil - :visible (and (< (clearcase-dired-mark-count) 2) - (clearcase-dired-current-ok-to-hijack))] - - ["Unhijack file" clearcase-unhijack-dired-files - :keys nil - :visible (and (< (clearcase-dired-mark-count) 2) - (clearcase-dired-current-ok-to-unhijack))] - - ["Find checkouts" clearcase-find-checkouts-in-current-view t] - - ["Make file an element" clearcase-mkelem-dired-files - :visible (and (< (clearcase-dired-mark-count) 2) - (clearcase-dired-current-ok-to-mkelem))] - - ;; Marked files - ;; - ["Checkin marked files" clearcase-checkin-dired-files - :keys nil - :visible (and (>= (clearcase-dired-mark-count) 2) - (clearcase-dired-marked-ok-to-checkin))] - - ["Checkout marked files" clearcase-checkout-dired-files - :keys nil - :visible (and (>= (clearcase-dired-mark-count) 2) - (clearcase-dired-marked-ok-to-checkout))] - - ["Uncheckout marked files" clearcase-uncheckout-dired-files - :keys nil - :visible (and (>= (clearcase-dired-mark-count) 2) - (clearcase-dired-marked-ok-to-uncheckout))] - - ["Hijack marked files" clearcase-hijack-dired-files - :keys nil - :visible (and (>= (clearcase-dired-mark-count) 2) - (clearcase-dired-marked-ok-to-hijack))] - - ["Unhijack marked files" clearcase-unhijack-dired-files - :keys nil - :visible (and (>= (clearcase-dired-mark-count) 2) - (clearcase-dired-marked-ok-to-unhijack))] - - ["Make marked files elements" clearcase-mkelem-dired-files - :keys nil - :visible (and (>= (clearcase-dired-mark-count) 2) - (clearcase-dired-marked-ok-to-mkelem))] - - - ;; Current directory - ;; - ["Checkin current-dir" clearcase-dired-checkin-current-dir - :keys nil - :visible (clearcase-dired-current-dir-ok-to-checkin)] - - ["Checkout current dir" clearcase-dired-checkout-current-dir - :keys nil - :visible (clearcase-dired-current-dir-ok-to-checkout)] - - ["Uncheckout current dir" clearcase-dired-uncheckout-current-dir - :keys nil - :visible (clearcase-dired-current-dir-ok-to-uncheckout)] - - "---------------------------------" - ["Describe file" clearcase-describe-dired-file - :visible t] - - ["Annotate file" clearcase-annotate-dired-file - :visible t] - - ["Show config-spec rule" clearcase-what-rule-dired-file - :visible t] - - - ["Edit config-spec" clearcase-edcs-edit t] - - "---------------------------------" - (list "Compare (Emacs)..." - ["Compare with predecessor" clearcase-ediff-pred-dired-file - :keys nil - :visible t] - ["Compare with branch base" clearcase-ediff-branch-base-dired-file - :keys nil - :visible t] - ["Compare with named version" clearcase-ediff-named-version-dired-file - :keys nil - :visible t]) - (list "Compare (GUI)..." - ["Compare with predecessor" clearcase-gui-diff-pred-dired-file - :keys nil - :visible t] - ["Compare with branch base" clearcase-gui-diff-branch-base-dired-file - :keys nil - :visible t] - ["Compare with named version" clearcase-gui-diff-named-version-dired-file - :keys nil - :visible t]) - (list "Compare (diff)..." - ["Compare with predecessor" clearcase-diff-pred-dired-file - :keys nil - :visible t] - ["Compare with branch base" clearcase-diff-branch-base-dired-file - :keys nil - :visible t] - ["Compare with named version" clearcase-diff-named-version-dired-file - :keys nil - :visible t]) - "---------------------------------" - ["Browse versions (dired)" clearcase-browse-vtree-dired-file - :visible (clearcase-dired-current-ok-to-browse)] - ["Vtree browser GUI" clearcase-gui-vtree-browser-dired-file - :keys nil - :visible t] - "---------------------------------" - (list "Update snapshot..." - ["Update view" clearcase-update-view - :keys nil - :visible (and (clearcase-file-is-in-view-p default-directory) - (not (clearcase-file-is-in-mvfs-p default-directory)))] - ["Update directory" clearcase-update-default-directory - :keys nil - :visible (and (clearcase-file-is-in-view-p default-directory) - (not (clearcase-file-is-in-mvfs-p default-directory)))] - ["Update file" clearcase-update-dired-files - :keys nil - :visible (and (< (clearcase-dired-mark-count) 2) - (clearcase-dired-current-ok-to-checkout) - (not (clearcase-file-is-in-mvfs-p default-directory)))] - ["Update marked files" clearcase-update-dired-files - :keys nil - :visible (and (>= (clearcase-dired-mark-count) 2) - (not (clearcase-file-is-in-mvfs-p default-directory)))] - ) - "---------------------------------" - (list "Element history..." - ["Element history (full)" clearcase-list-history-dired-file - :keys nil - :visible t] - ["Element history (branch)" clearcase-list-history-dired-file - :keys nil - :visible t] - ["Element history (me)" clearcase-list-history-dired-file - :keys nil - :visible t]) - "---------------------------------" - ["Show current activity" clearcase-ucm-describe-current-activity - :keys nil - :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))] - ["Make activity" clearcase-ucm-mkact-current-dir - :keys nil - :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))] - ["Set activity..." clearcase-ucm-set-activity-current-dir - :keys nil - :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))] - ["Set NO activity" clearcase-ucm-set-activity-none-current-dir - :keys nil - :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))] - ["Rebase this stream" clearcase-gui-rebase - :keys nil - :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))] - ["Deliver from this stream" clearcase-gui-deliver - :keys nil - :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))] - "---------------------------------" - (list "ClearCase GUI" - ["ClearCase Explorer" clearcase-gui-clearexplorer - :keys nil - :visible clearcase-on-mswindows] - ["Project Explorer" clearcase-gui-project-explorer - :keys nil] - ["Merge Manager" clearcase-gui-merge-manager - :keys nil] - ["Snapshot View Updater" clearcase-gui-snapshot-view-updater - :keys nil]) - "---------------------------------" - - ["Make branch type" clearcase-mkbrtype - :keys nil] - - "---------------------------------" - ["Report Bug in ClearCase Mode" clearcase-submit-bug-report - :keys nil] - - ["Dump internals" clearcase-dump - :keys nil - :visible (or (equal "rwhitby" (user-login-name)) - (equal "esler" (user-login-name)))] - - ["Flush caches" clearcase-flush-caches - :keys nil - :visible (or (equal "rwhitby" (user-login-name)) - (equal "esler" (user-login-name)))] - - "---------------------------------" - ["Customize..." (customize-group 'clearcase) - :keys nil])) - -(defvar clearcase-dired-menu-contents - (list "ClearCase" - - ;; Current file - ;; - ["Checkin file" clearcase-checkin-dired-files - :keys nil - :active (and (< (clearcase-dired-mark-count) 2) - (clearcase-dired-current-ok-to-checkin))] - - ["Edit checkout comment" clearcase-edit-checkout-comment-dired-file - :keys nil - :active (and (< (clearcase-dired-mark-count) 2) - (clearcase-dired-current-ok-to-checkin))] - - ["Checkout file" clearcase-checkout-dired-files - :keys nil - :active (and (< (clearcase-dired-mark-count) 2) - (clearcase-dired-current-ok-to-checkout))] - - ["Uncheckout file" clearcase-uncheckout-dired-files - :keys nil - :active (and (< (clearcase-dired-mark-count) 2) - (clearcase-dired-current-ok-to-uncheckout))] - - ["Hijack file" clearcase-hijack-dired-files - :keys nil - :active (and (< (clearcase-dired-mark-count) 2) - (clearcase-dired-current-ok-to-hijack))] - - ["Unhijack file" clearcase-unhijack-dired-files - :keys nil - :active (and (< (clearcase-dired-mark-count) 2) - (clearcase-dired-current-ok-to-unhijack))] - - ["Make file an element" clearcase-mkelem-dired-files - :active (and (< (clearcase-dired-mark-count) 2) - (clearcase-dired-current-ok-to-mkelem))] - - ;; Marked files - ;; - ["Checkin marked files" clearcase-checkin-dired-files - :keys nil - :active (and (>= (clearcase-dired-mark-count) 2) - (clearcase-dired-marked-ok-to-checkin))] - - ["Checkout marked files" clearcase-checkout-dired-files - :keys nil - :active (and (>= (clearcase-dired-mark-count) 2) - (clearcase-dired-marked-ok-to-checkout))] - - ["Uncheckout marked files" clearcase-uncheckout-dired-files - :keys nil - :active (and (>= (clearcase-dired-mark-count) 2) - (clearcase-dired-marked-ok-to-uncheckout))] - - ["Hijack marked files" clearcase-hijack-dired-files - :keys nil - :active (and (>= (clearcase-dired-mark-count) 2) - (clearcase-dired-marked-ok-to-hijack))] - - ["Unhijack marked files" clearcase-unhijack-dired-files - :keys nil - :active (and (>= (clearcase-dired-mark-count) 2) - (clearcase-dired-marked-ok-to-unhijack))] - - ["Make marked files elements" clearcase-mkelem-dired-files - :keys nil - :active (and (>= (clearcase-dired-mark-count) 2) - (clearcase-dired-marked-ok-to-mkelem))] - - - ;; Current directory - ;; - ["Checkin current-dir" clearcase-dired-checkin-current-dir - :keys nil - :active (clearcase-dired-current-dir-ok-to-checkin)] - - ["Checkout current dir" clearcase-dired-checkout-current-dir - :keys nil - :active (clearcase-dired-current-dir-ok-to-checkout)] - - ["Uncheckout current dir" clearcase-dired-uncheckout-current-dir - :keys nil - :active (clearcase-dired-current-dir-ok-to-uncheckout)] - - "---------------------------------" - ["Describe file" clearcase-describe-dired-file - :active t] - - ["Annotate file" clearcase-annotate-dired-file - :active t] - - ["Show config-spec rule" clearcase-what-rule-dired-file - :active t] - - - ["Edit config-spec" clearcase-edcs-edit t] - - "---------------------------------" - (list "Compare (Emacs)..." - ["Compare with predecessor" clearcase-ediff-pred-dired-file - :keys nil - :active t] - ["Compare with branch base" clearcase-ediff-branch-base-dired-file - :keys nil - :active t] - ["Compare with named version" clearcase-ediff-named-version-dired-file - :keys nil - :active t]) - (list "Compare (GUI)..." - ["Compare with predecessor" clearcase-gui-diff-pred-dired-file - :keys nil - :active t] - ["Compare with branch base" clearcase-gui-diff-branch-base-dired-file - :keys nil - :active t] - ["Compare with named version" clearcase-gui-diff-named-version-dired-file - :keys nil - :active t]) - (list "Compare (diff)..." - ["Compare with predecessor" clearcase-diff-pred-dired-file - :keys nil - :active t] - ["Compare with branch base" clearcase-diff-branch-base-dired-file - :keys nil - :active t] - ["Compare with named version" clearcase-diff-named-version-dired-file - :keys nil - :active t]) - "---------------------------------" - ["Browse versions (dired)" clearcase-browse-vtree-dired-file - :active (clearcase-dired-current-ok-to-browse)] - ["Vtree browser GUI" clearcase-gui-vtree-browser-dired-file - :keys nil - :active t] - "---------------------------------" - (list "Update snapshot..." - ["Update view" clearcase-update-view - :keys nil - :active (and (clearcase-file-is-in-view-p default-directory) - (not (clearcase-file-is-in-mvfs-p default-directory)))] - ["Update directory" clearcase-update-default-directory - :keys nil - :active (and (clearcase-file-is-in-view-p default-directory) - (not (clearcase-file-is-in-mvfs-p default-directory)))] - ["Update file" clearcase-update-dired-files - :keys nil - :active (and (< (clearcase-dired-mark-count) 2) - (clearcase-dired-current-ok-to-checkout) - (not (clearcase-file-is-in-mvfs-p default-directory)))] - ["Update marked files" clearcase-update-dired-files - :keys nil - :active (and (>= (clearcase-dired-mark-count) 2) - (not (clearcase-file-is-in-mvfs-p default-directory)))] - ) - "---------------------------------" - (list "Element history..." - ["Element history (full)" clearcase-list-history-dired-file - :keys nil - :active t] - ["Element history (branch)" clearcase-list-history-dired-file - :keys nil - :active t] - ["Element history (me)" clearcase-list-history-dired-file - :keys nil - :active t]) - "---------------------------------" - ["Show current activity" clearcase-ucm-describe-current-activity - :keys nil - :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))] - ["Make activity" clearcase-ucm-mkact-current-dir - :keys nil - :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))] - ["Set activity..." clearcase-ucm-set-activity-current-dir - :keys nil - :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))] - ["Set NO activity" clearcase-ucm-set-activity-none-current-dir - :keys nil - :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))] - ["Rebase this stream" clearcase-gui-rebase - :keys nil - :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))] - ["Deliver from this stream" clearcase-gui-deliver - :keys nil - :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))] - "---------------------------------" - (list "ClearCase GUI" - ["ClearCase Explorer" clearcase-gui-clearexplorer - :keys nil - :active clearcase-on-mswindows] - ["Project Explorer" clearcase-gui-project-explorer - :keys nil] - ["Merge Manager" clearcase-gui-merge-manager - :keys nil] - ["Snapshot View Updater" clearcase-gui-snapshot-view-updater - :keys nil]) - "---------------------------------" - - ["Make branch type" clearcase-mkbrtype - :keys nil] - - "---------------------------------" - ["Report Bug in ClearCase Mode" clearcase-submit-bug-report - :keys nil] - - ["Dump internals" clearcase-dump - :keys nil - :active (or (equal "rwhitby" (user-login-name)) - (equal "esler" (user-login-name)))] - - ["Flush caches" clearcase-flush-caches - :keys nil - :active (or (equal "rwhitby" (user-login-name)) - (equal "esler" (user-login-name)))] - - "---------------------------------" - ["Customize..." (customize-group 'clearcase) - :keys nil])) - -(if (and clearcase-minimise-menus - (not clearcase-xemacs-p)) - (setq clearcase-dired-menu-contents clearcase-dired-menu-contents-minimised)) - -;;}}} - -(if (>= emacs-major-version '20) - (progn - (easy-menu-define - clearcase-dired-menu - (list clearcase-dired-mode-map) - "ClearCase Dired menu" - clearcase-dired-menu-contents) - - (or clearcase-xemacs-p - (add-to-list 'menu-bar-final-items 'ClearCase)))) - -;;}}} - -;;}}} - -;;{{{ Widgets - -;;{{{ Single-selection buffer widget - -;; Keep the compiler quiet by declaring these -;; buffer-local variables here thus. -;; -(defvar clearcase-selection-window-config nil) -(defvar clearcase-selection-interpreter nil) -(defvar clearcase-selection-continuation nil) -(defvar clearcase-selection-operands nil) - -(defun clearcase-ucm-make-selection-window (buffer-name - buffer-contents - selection-interpreter - continuation - cont-arglist) - (let ((buf (get-buffer-create buffer-name))) - (save-excursion - - ;; Reset the buffer - ;; - (set-buffer buf) - (setq buffer-read-only nil) - (erase-buffer) - (setq truncate-lines t) - - ;; Paint the buffer - ;; - (goto-char (point-min)) - (insert buffer-contents) - - ;; Insert mouse-highlighting - ;; - (save-excursion - (goto-char (point-min)) - (while (< (point) (point-max)) - (condition-case nil - (progn - (beginning-of-line) - (put-text-property (point) - (save-excursion - (end-of-line) - (point)) - 'mouse-face 'highlight)) - (error nil)) - (forward-line 1))) - - ;; Set a keymap - ;; - (setq buffer-read-only t) - (use-local-map clearcase-selection-keymap) - - ;; Set up the interpreter and continuation - ;; - (set (make-local-variable 'clearcase-selection-window-config) - (current-window-configuration)) - (set (make-local-variable 'clearcase-selection-interpreter) - selection-interpreter) - (set (make-local-variable 'clearcase-selection-continuation) - continuation) - (set (make-local-variable 'clearcase-selection-operands) - cont-arglist)) - - ;; Display the buffer - ;; - (pop-to-buffer buf) - (goto-char 0) - (shrink-window-if-larger-than-buffer) - (message "Use RETURN to select an item"))) - -(defun clearcase-selection-continue () - (interactive) - (beginning-of-line) - (sit-for 0) - ;; Call the interpreter to extract the item of interest - ;; from the buffer. - ;; - (let ((item (funcall clearcase-selection-interpreter))) - ;; Call the continuation. - ;; - (apply clearcase-selection-continuation - (append clearcase-selection-operands (list item)))) - - ;; Restore window config - ;; - (let ((sel-buffer (current-buffer))) - (if clearcase-selection-window-config - (set-window-configuration clearcase-selection-window-config)) - (delete-windows-on sel-buffer) - (kill-buffer sel-buffer))) - -(defun clearcase-selection-mouse-continue (click) - (interactive "@e") - (mouse-set-point click) - (clearcase-selection-continue)) - -(defvar clearcase-selection-keymap - (let ((map (make-sparse-keymap))) - (define-key map [return] 'clearcase-selection-continue) - (define-key map [mouse-2] 'clearcase-selection-mouse-continue) - (define-key map "q" 'clearcase-utl-kill-view-buffer) - ;; nyi: refresh list - ;; (define-key map "g" 'clearcase-selection-get) - map)) - -;;}}} - -;;}}} - -;;{{{ Integration with Emacs - -;;{{{ Functions: examining the ClearCase installation - -;; Discover ClearCase version-string -;; -(defun clearcase-get-version-string () - ;; Some care seems to be necessary to avoid problems caused by odd settings - ;; of the "SHELL" environment variable. I found that simply - ;; (shell-command-to-string "cleartool -version") on Windows-2000 with - ;; SHELL==cmd.exe just returned a copy of the Windows command prompt. The - ;; result was that clearcase-integrate would not complete. - ;; - ;; The follow seems to work. - ;; - (if clearcase-on-mswindows - (shell-command-to-string "cmd /c cleartool -version") - (shell-command-to-string "sh -c \"cleartool -version\""))) - -;; Find where cleartool is installed. -;; -(defun clearcase-find-cleartool () - "Search directories listed in the PATH environment variable -looking for a cleartool executable. If found return the full pathname." - (let ((dir-list (parse-colon-path (getenv "PATH"))) - (cleartool-name (if clearcase-on-mswindows - "cleartool.exe" - "cleartool")) - (cleartool-path nil)) - (catch 'found - (mapcar - (function (lambda (dir) - (let ((f (expand-file-name (concat dir cleartool-name)))) - (if (file-executable-p f) - (progn - (setq cleartool-path f) - (throw 'found t)))))) - dir-list) - nil) - cleartool-path)) - -(defun clearcase-non-lt-registry-server-online-p () - "Heuristic to determine if the local host is network-connected to -its ClearCase servers. Used for a non-LT system." - - (let ((result nil) - (buf (get-buffer-create " *clearcase-lsregion*"))) - (save-excursion - (set-buffer buf) - (erase-buffer) - (let ((process (start-process "lsregion" - buf - "cleartool" - "lsregion" - "-long")) - (timeout-occurred nil)) - - ;; Now wait a little while, if necessary, for some output. - ;; - (while (and (null result) - (not timeout-occurred) - (< (buffer-size) (length "Tag: "))) - (if (null (accept-process-output process 10)) - (setq timeout-occurred t)) - (goto-char (point-min)) - (if (looking-at "Tag: ") - (setq result t))) - (condition-case nil - (kill-process process) - (error nil)))) - ;; If servers are apparently not online, keep the - ;; buffer around so we can see what lsregion reported. - ;; - (sit-for 0.01); Fix by AJM to prevent kill-buffer claiming process still running - (if result - (kill-buffer buf)) - result)) - -;; We could have an LT system, which lacks ct+lsregion, but has ct+lssite. -;; -(defun clearcase-lt-registry-server-online-p () - "Heuristic to determine if the local host is network-connected to -its ClearCase servers. Used for LT system." - - (let ((result nil) - (buf (get-buffer-create " *clearcase-lssite*"))) - (save-excursion - (set-buffer buf) - (erase-buffer) - (let ((process (start-process "lssite" - buf - "cleartool" - "lssite" - "-inquire")) - (timeout-occurred nil)) - - ;; Now wait a little while, if necessary, for some output. - ;; - (while (and (null result) - (not timeout-occurred) - (< (buffer-size) (length " view_cache_size"))) - (if (null (accept-process-output process 10)) - (setq timeout-occurred t)) - (goto-char (point-min)) - (if (re-search-forward "view_cache_size" nil t) - (setq result t))) - (condition-case nil - (kill-process process) - (error nil)))) - - ;; If servers are apparently not online, keep the - ;; buffer around so we can see what lssite reported. - ;; - (sit-for 0.01); Fix by AJM to prevent kill-buffer claiming process still running - (if result - (kill-buffer buf)) - result)) - -;; Find out if the ClearCase registry server is accessible. -;; We could be on a disconnected laptop. -;; -(defun clearcase-registry-server-online-p () - "Heuristic to determine if the local host is network-connected to -its ClearCase server(s)." - - (if clearcase-lt - (clearcase-lt-registry-server-online-p) - (clearcase-non-lt-registry-server-online-p))) - -;;}}} -;;{{{ Functions: hooks - -;;{{{ A find-file hook to turn on clearcase-mode - -(defun clearcase-hook-find-file-hook () - (let ((filename (buffer-file-name))) - (if filename - (progn - (clearcase-fprop-unstore-properties filename) - (if (clearcase-file-would-be-in-view-p filename) - (progn - ;; 1. Activate minor mode - ;; - (clearcase-mode 1) - - ;; 2. Pre-fetch file properties - ;; - (if (file-exists-p filename) - (progn - (clearcase-fprop-get-properties filename) - - ;; 3. Put branch/ver in mode-line - ;; - (setq clearcase-mode - (concat " ClearCase:" - (clearcase-mode-line-buffer-id filename))) - (force-mode-line-update) - - ;; 4. Schedule the asynchronous fetching of the view's properties - ;; next time Emacs is idle enough. - ;; - (clearcase-vprop-schedule-work (clearcase-fprop-viewtag filename)) - - ;; 5. Set backup policy - ;; - (unless clearcase-make-backup-files - (make-local-variable 'backup-inhibited) - (setq backup-inhibited t)))) - - (clearcase-set-auto-mode))))))) - -(defun clearcase-set-auto-mode () - "Check again for the mode of the current buffer when using ClearCase version extended paths." - - (let* ((version (clearcase-vxpath-version-part (buffer-file-name))) - (buffer-file-name (clearcase-vxpath-element-part (buffer-file-name)))) - - ;; Need to recheck the major mode only if a version was appended. - ;; - (if version - (set-auto-mode)))) - -;;}}} - -;;{{{ A find-file hook for version-extended pathnames - -(defun clearcase-hook-vxpath-find-file-hook () - (if (clearcase-vxpath-p default-directory) - (let ((element (clearcase-vxpath-element-part default-directory)) - (version (clearcase-vxpath-version-part default-directory))) - - ;; 1. Set the buffer name to @@//. - ;; - (let ((new-buffer-name - (concat (file-name-nondirectory element) - clearcase-vxpath-glue - version - (buffer-name)))) - - (or (string= new-buffer-name (buffer-name)) - - ;; Uniquify the name, if necessary. - ;; - (let ((n 2) - (uniquifier-string "")) - (while (get-buffer (concat new-buffer-name uniquifier-string)) - (setq uniquifier-string (format "<%d>" n)) - (setq n (1+ n))) - (rename-buffer - (concat new-buffer-name uniquifier-string))))) - - ;; 2. Set the default directory to the dir containing . - ;; - (let ((new-dir (file-name-directory element))) - (setq default-directory new-dir)) - - ;; 3. Disable auto-saving. - ;; - ;; If we're visiting @@//199 - ;; we don't want Emacs trying to find a place to create a "#199#. - ;; - (auto-save-mode 0)))) - -;;}}} - -;;{{{ A dired-mode-hook to turn on clearcase-dired-mode - -(defun clearcase-hook-dired-mode-hook () - ;; Force a re-computation of whether the directory is within ClearCase. - ;; - (clearcase-fprop-unstore-properties default-directory) - - ;; Wrap this in an exception handler. Otherwise, diredding into - ;; a deregistered or otherwise defective snapshot-view fails. - ;; - (condition-case nil - ;; If this directory is below a ClearCase element, - ;; 1. turn on ClearCase Dired Minor Mode. - ;; 2. display branch/ver in mode-line - ;; - (if (clearcase-file-would-be-in-view-p default-directory) - (progn - (if clearcase-auto-dired-mode - (progn - (clearcase-dired-mode 1) - (clearcase-fprop-get-properties default-directory) - (clearcase-vprop-schedule-work (clearcase-fprop-viewtag default-directory)))) - (setq clearcase-dired-mode - (concat " ClearCase:" - (clearcase-mode-line-buffer-id default-directory))) - (force-mode-line-update))) - (error (message "Error fetching ClearCase properties of %s" default-directory)))) - -;;}}} - -;;{{{ A dired-after-readin-hook to add ClearCase information to the display - -(defun clearcase-hook-dired-after-readin-hook () - - ;; If in clearcase-dired-mode, reformat the buffer. - ;; - (if clearcase-dired-mode - (progn - (clearcase-dired-reformat-buffer) - (if clearcase-dired-show-view - (clearcase-dired-insert-viewtag)))) - t) - -;;}}} - -;;{{{ A write-file-hook to auto-insert a version-string. - -;; To use this, put a line containing this in the first 8 lines of your file: -;; ClearCase-version: -;; and make sure that clearcase-version-stamp-active gets set to true at least -;; locally in the file. - -(defvar clearcase-version-stamp-line-limit 1000) -(defvar clearcase-version-stamp-begin-regexp "ClearCase-version:[ \t]<") -(defvar clearcase-version-stamp-end-regexp ">") -(defvar clearcase-version-stamp-active nil) - -(defun clearcase-increment-version (version-string) - (let* ((branch (clearcase-vxpath-branch version-string)) - (number (clearcase-vxpath-version version-string)) - (new-number (1+ (string-to-number number)))) - (format "%s%d" branch new-number))) - -(defun clearcase-version-stamp () - (interactive) - (if (and clearcase-mode - clearcase-version-stamp-active - (file-exists-p buffer-file-name) - (equal 'version (clearcase-fprop-mtype buffer-file-name))) - (let ((latest-version (clearcase-fprop-predecessor-version buffer-file-name))) - - ;; Note: If the buffer happens to be folded, we may not find the place - ;; to insert the version-stamp. Folding mode really needs to supply a - ;; 'save-folded-excursion function to solve this one. We won't attempt - ;; a cheaper hack here. - - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (forward-line clearcase-version-stamp-line-limit) - (let ((limit (point)) - (v-start nil) - (v-end nil)) - (goto-char (point-min)) - (while (and (< (point) limit) - (re-search-forward clearcase-version-stamp-begin-regexp - limit - 'move)) - (setq v-start (point)) - (end-of-line) - (let ((line-end (point))) - (goto-char v-start) - (if (re-search-forward clearcase-version-stamp-end-regexp - line-end - 'move) - (setq v-end (match-beginning 0))))) - (if v-end - (let ((new-version-stamp (clearcase-increment-version latest-version))) - (goto-char v-start) - (delete-region v-start v-end) - (insert-and-inherit new-version-stamp))))))))) - -(defun clearcase-hook-write-file-hook () - - (clearcase-version-stamp) - ;; Important to return nil so the files eventually gets written. - ;; - nil) - -;;}}} - -;;{{{ A kill-buffer hook - -(defun clearcase-hook-kill-buffer-hook () - (let ((filename (buffer-file-name))) - (if (and filename - ;; W3 has buffers in which 'buffer-file-name is bound to - ;; a URL. Don't attempt to unstore their properties. - ;; - (boundp 'buffer-file-truename) - buffer-file-truename) - (clearcase-fprop-unstore-properties filename)))) - -;;}}} - -;;{{{ A kill-emacs-hook - -(defun clearcase-hook-kill-emacs-hook () - (clearcase-utl-clean-tempfiles)) - -;;}}} - -;;}}} -;;{{{ Function: to replace toggle-read-only - -(defun clearcase-toggle-read-only (&optional arg) - "Change read-only status of current buffer, perhaps via version control. -If the buffer is visiting a ClearCase version, then check the file in or out. -Otherwise, just change the read-only flag of the buffer. If called with an -argument then just change the read-only flag even if visiting a ClearCase -version." - (interactive "P") - (cond (arg - (toggle-read-only)) - ((and (clearcase-fprop-mtype buffer-file-name) - buffer-read-only - (file-writable-p buffer-file-name) - (/= 0 (user-uid))) - (toggle-read-only)) - - ((clearcase-fprop-mtype buffer-file-name) - (clearcase-next-action-current-buffer)) - - (t - (toggle-read-only)))) - -;;}}} -;;{{{ Functions: file-name-handlers - -;;{{{ Start dynamic views automatically when paths to them are used - -;; This handler starts views when viewroot-relative paths are dereferenced. -;; -;; nyi: for now really only seems useful on Unix. -;; -(defun clearcase-viewroot-relative-file-name-handler (operation &rest args) - - (clearcase-when-debugging - (if (fboundp 'clearcase-utl-syslog) - (clearcase-utl-syslog "*clearcase-fh-trace*" - (cons "clearcase-viewroot-relative-file-name-handler:" - (cons operation args))))) - - ;; Inhibit the handler to avoid recursion. - ;; - (let ((inhibit-file-name-handlers - (cons 'clearcase-viewroot-relative-file-name-handler - (and (eq inhibit-file-name-operation operation) - inhibit-file-name-handlers))) - (inhibit-file-name-operation operation)) - - (let ((first-arg (car args))) - ;; We don't always get called with a string. - ;; e.g. one file operation is verify-visited-file-modtime, whose - ;; first argument is a buffer. - ;; - (if (stringp first-arg) - (progn - ;; Now start the view if necessary - ;; - (save-match-data - (let* ((path (clearcase-path-remove-useless-viewtags first-arg)) - (viewtag (clearcase-vrpath-viewtag path)) - (default-directory (clearcase-path-remove-useless-viewtags default-directory))) - (if viewtag - (clearcase-viewtag-try-to-start-view viewtag)))))) - (apply operation args)))) - -;;}}} - -;;{{{ Completion on viewtags - -;; This handler provides completion for viewtags. -;; -(defun clearcase-viewtag-file-name-handler (operation &rest args) - - (clearcase-when-debugging - (if (fboundp 'clearcase-utl-syslog) - (clearcase-utl-syslog "*clearcase-fh-trace*" - (cons "clearcase-viewtag-file-name-handler:" - (cons operation args))))) - (cond - - ((eq operation 'file-name-completion) - (save-match-data (apply 'clearcase-viewtag-completion args))) - - ((eq operation 'file-name-all-completions) - (save-match-data (apply 'clearcase-viewtag-completions args))) - - (t - (let ((inhibit-file-name-handlers - (cons 'clearcase-viewtag-file-name-handler - (and (eq inhibit-file-name-operation operation) - inhibit-file-name-handlers))) - (inhibit-file-name-operation operation)) - (apply operation args))))) - -(defun clearcase-viewtag-completion (file dir) - (try-completion file (clearcase-viewtag-all-viewtag-dirs-obarray))) - -(defun clearcase-viewtag-completions (file dir) - (let ((tags (all-completions file - (clearcase-viewtag-all-viewtags-obarray)))) - (mapcar - (function (lambda (tag) - (concat tag "/"))) - tags))) - -;;}}} - -;;{{{ File name handler for version extended file names - -;; For version extended pathnames there are two possible answers -;; for each of -;; file-name-directory -;; file-name-nondirectory -;; -;; 1. that pertaining to the element path, e.g. -;; (file-name-directory "DIR/FILE@@/BRANCH/VERSION") -;; ==> "DIR/" -;; 2. that pertaining to the version path, e.g. -;; (file-name-directory "DIR/FILE@@/BRANCH/VERSION") -;; ==> "DIR/FILE@@/BRANCH/" -;; -;; Often we'd like the former, but sometimes we'd like the latter, for example -;; inside clearcase-browse-vtree, where it calls dired. Within dired on Gnu -;; Emacs, it calls file-name-directory on the supplied pathname and in this -;; case we want the version (i.e. branch) path to be used. -;; -;; How to get the behaviour we want ? - -;; APPROACH A: -;; ========== -;; -;; Define a variable clearcase-treat-branches-as-dirs, which modifies -;; the behaviour of clearcase-vxpath-file-name-handler to give answer (1). -;; -;; Just before we invoke dired inside clearcase-browse-vtree, dynamically -;; bind clearcase-treat-branches-as-dirs to t. Also in the resulting Dired Mode -;; buffer, make clearcase-treat-branches-as-dirs buffer-local and set it. -;; -;; Unfortunately this doesn't quite give us what we want. For example I often -;; invoke grep from a dired buffer on a branch-qua-directory to scan all the -;; version on that branch for a certain string. The grep-mode buffer has no -;; buffer-local binding for clearcase-treat-branches-as-dirs so the grep -;; command runs in "DIR/" instead of in "DIR/FILE@@/BRANCH/". -;; -;; APPROACH B: -;; ========== -;; -;; Modify the semantics of clearcase-vxpath-file-name-handler so that -;; if the filename given is a pathname to an existing branch-qua-directory -;; give answer 2, otherwise give answer 1. -;; -;; APPROACH C: -;; ========== -;; -;; Use the existence of a Dired Mode buffer on "DIR/FILE@@/BRANCH/" to -;; change the semantics of clearcase-vxpath-file-name-handler. -;; -;; (A) is unsatisfactory and I'm not entirely happy with (B) nor (C) so for now -;; I'm going to disable this filename handler until I'm more convinced it is -;; needed. - -(defun clearcase-vxpath-file-name-handler (operation &rest args) - (clearcase-when-debugging - (if (fboundp 'clearcase-utl-syslog) - (clearcase-utl-syslog "*clearcase-fh-trace*" - (cons "clearcase-vxpath-file-name-handler:" - (cons operation args))))) - ;; Inhibit recursion: - ;; - (let ((inhibit-file-name-handlers - (cons 'clearcase-vxpath-file-name-handler - (and (eq inhibit-file-name-operation operation) - inhibit-file-name-handlers))) - (inhibit-file-name-operation operation)) - - (cond ((eq operation 'file-name-nondirectory) - (file-name-nondirectory (clearcase-vxpath-element-part - (car args)))) - - ((eq operation 'file-name-directory) - (file-name-directory (clearcase-vxpath-element-part - (car args)))) - - (t - (apply operation args))))) - -;;}}} - -;;}}} -;;{{{ Advice: Disable VC in the MVFS - -;; This handler ensures that VC doesn't attempt to operate inside the MVFS. -;; This stops it from futile searches for RCS directories and the like inside. -;; It prevents a certain amount of clutter in the MVFS' noent-cache. -;; - -(defadvice vc-registered (around clearcase-interceptor disable compile) - "Disable normal behavior if in a clearcase dynamic view. -This is enabled/disabled by clearcase-integrate/clearcase-unintegrate." - (if (clearcase-file-would-be-in-view-p (ad-get-arg 0)) - nil - ad-do-it)) - -;;}}} - -;;{{{ Functions: integrate and un-integrate. - -(defun clearcase-integrate () - "Enable ClearCase integration" - (interactive) - - ;; 0. Empty caches. - ;; - (clearcase-fprop-clear-all-properties) - (clearcase-vprop-clear-all-properties) - - ;; 1. Install hooks. - ;; - (add-hook 'find-file-hooks 'clearcase-hook-find-file-hook) - (add-hook 'find-file-hooks 'clearcase-hook-vxpath-find-file-hook) - (add-hook 'dired-mode-hook 'clearcase-hook-dired-mode-hook) - (add-hook 'dired-after-readin-hook 'clearcase-hook-dired-after-readin-hook) - (add-hook 'kill-buffer-hook 'clearcase-hook-kill-buffer-hook) - (add-hook 'write-file-hooks 'clearcase-hook-write-file-hook) - (add-hook 'kill-emacs-hook 'clearcase-hook-kill-emacs-hook) - - ;; 2. Install file-name handlers. - ;; - ;; 2.1 Start views when //view/TAG or m:/TAG is referenced. - ;; - (add-to-list 'file-name-handler-alist - (cons clearcase-vrpath-regexp - 'clearcase-viewroot-relative-file-name-handler)) - - ;; 2.2 Completion on viewtags. - ;; - (if clearcase-complete-viewtags - (add-to-list 'file-name-handler-alist - (cons clearcase-viewtag-regexp - 'clearcase-viewtag-file-name-handler))) - - ;; 2.3 Turn off RCS/VCS/SCCS activity inside a ClearCase dynamic view. - ;; - (if clearcase-suppress-vc-within-mvfs - (when clearcase-suppress-vc-within-mvfs - (ad-enable-advice 'vc-registered 'around 'clearcase-interceptor) - (ad-activate 'vc-registered))) - - ;; Disabled for now. See comments above clearcase-vxpath-file-name-handler. - ;; - ;; ;; 2.4 Add file name handler for version extended path names - ;; ;; - ;; (add-to-list 'file-name-handler-alist - ;; (cons clearcase-vxpath-glue 'clearcase-vxpath-file-name-handler)) - ) - -(defun clearcase-unintegrate () - "Disable ClearCase integration" - (interactive) - - ;; 0. Empty caches. - ;; - (clearcase-fprop-clear-all-properties) - (clearcase-vprop-clear-all-properties) - - ;; 1. Remove hooks. - ;; - (remove-hook 'find-file-hooks 'clearcase-hook-find-file-hook) - (remove-hook 'find-file-hooks 'clearcase-hook-vxpath-find-file-hook) - (remove-hook 'dired-mode-hook 'clearcase-hook-dired-mode-hook) - (remove-hook 'dired-after-readin-hook 'clearcase-hook-dired-after-readin-hook) - (remove-hook 'kill-buffer-hook 'clearcase-hook-kill-buffer-hook) - (remove-hook 'write-file-hooks 'clearcase-hook-write-file-hook) - (remove-hook 'kill-emacs-hook 'clearcase-hook-kill-emacs-hook) - - ;; 2. Remove file-name handlers. - ;; - (setq file-name-handler-alist - (delete-if (function - (lambda (entry) - (memq (cdr entry) - '(clearcase-viewroot-relative-file-name-handler - clearcase-viewtag-file-name-handler - clearcase-vxpath-file-name-handler)))) - file-name-handler-alist)) - - ;; 3. Turn on RCS/VCS/SCCS activity everywhere. - ;; - (ad-disable-advice 'vc-registered 'around 'clearcase-interceptor) - (ad-activate 'vc-registered)) - -;;}}} - -;; Here's where we really wire it all in: -;; -(defvar clearcase-cleartool-path nil) -(defvar clearcase-clearcase-version-installed nil) -(defvar clearcase-lt nil) -(defvar clearcase-v3 nil) -(defvar clearcase-v4 nil) -(defvar clearcase-v6 nil) -(defvar clearcase-servers-online nil) -(defvar clearcase-setview-root nil) -(defvar clearcase-setview-viewtag) -(defvar clearcase-setview-root nil) -(defvar clearcase-setview-viewtag nil) - -(progn - ;; If the SHELL environment variable points to the wrong place, - ;; call-process fails on Windows and this startup fails. - ;; Check for this and unset the useless EV. - - (let ((shell-ev-value (getenv "SHELL"))) - (if clearcase-on-mswindows - (if (stringp shell-ev-value) - (if (not (executable-find shell-ev-value)) - (setenv "SHELL" nil))))) - - ;; Things have to be done here in a certain order. - ;; - ;; 1. Make sure cleartool is on the shell search PATH. - ;; - (if (setq clearcase-cleartool-path (clearcase-find-cleartool)) - (progn - ;; 2. Try to discover what version of ClearCase we have: - ;; - (setq clearcase-clearcase-version-installed (clearcase-get-version-string)) - (setq clearcase-lt - (not (null (string-match "ClearCase LT" - clearcase-clearcase-version-installed)))) - (setq clearcase-v3 - (not (null (string-match "^ClearCase version 3" - clearcase-clearcase-version-installed)))) - (setq clearcase-v4 - (not (null (string-match "^ClearCase version 4" - clearcase-clearcase-version-installed)))) - (setq clearcase-v5 - (not (null (string-match "^ClearCase \\(LT \\)?version 2002.05" - clearcase-clearcase-version-installed)))) - (setq clearcase-v6 - (not (null (string-match "^ClearCase \\(LT \\)?version 2003.06" - clearcase-clearcase-version-installed)))) - - ;; 3. Gather setview information: - ;; - (if (setq clearcase-setview-root (if (not clearcase-on-mswindows) - (getenv "CLEARCASE_ROOT"))) - (setq clearcase-setview-viewtag - (file-name-nondirectory clearcase-setview-root))) - - ;; 4. Discover if the servers appear to be online. - ;; - (setq clearcase-servers-online (clearcase-registry-server-online-p)) - - (if clearcase-servers-online - - ;; 5. Everything seems in place to ensure that ClearCase mode will - ;; operate correctly, so integrate now. - ;; - (progn - (clearcase-integrate) - ;; Schedule a fetching of the view properties when next idle. - ;; This avoids awkward pauses after the user reaches for the - ;; ClearCase menubar entry. - ;; - (if clearcase-setview-viewtag - (clearcase-vprop-schedule-work clearcase-setview-viewtag))))))) - -(if (not clearcase-servers-online) - (message "ClearCase apparently not online. ClearCase/Emacs integration not installed.")) - -;;}}} - -(provide 'clearcase) - -;;; clearcase.el ends here