The SSH host key has changed on 8 April, 2022 to this one: SHA256:573uTBSeh74kvOo0HJXi5ijdzRm8me27suzNEDlGyrQ
My .emacs.d directory
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
my-emacs-d/clearcase.el

7968 lines
283 KiB

;;; clearcase.el --- ClearCase/Emacs integration.
;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2006, 2007 Kevin Esler
;; Author: Kevin Esler <kaesler@us.ibm.com>
;; Maintainer: Kevin Esler <kaesler@us.ibm.com>
;; 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: </main/laptop/166>")
(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*<N>
;; - 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