rc/xemacs/clearcase.el

   1 ;;; clearcase.el --- ClearCase/Emacs integration.
   2
   3 ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004 Kevin Esler
   4
   5 ;; Author: Kevin Esler <kaesler@us.ibm.com>
   6 ;; Maintainer: Kevin Esler <kaesler@us.ibm.com>
   7 ;; Keywords: clearcase tools
   8 ;; Web home: http://members.verizon.net/~vze24fr2/EmacsClearCase
   9
  10 ;; This file is not part of GNU Emacs.
  11 ;;
  12 ;; This program is free software; you can redistribute it and/or modify it under
  13 ;; the terms of the GNU General Public License as published by the Free Software
  14 ;; Foundation; either version 2, or (at your option) any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful, but WITHOUT
  17 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  18 ;; FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
  19 ;; details.
  20
  21 ;; You should have received a copy of the GNU General Public License along with
  22 ;; GNU Emacs; see the file COPYING.  If not, write to the Free Software
  23 ;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  24
  25 ;;{{{ Introduction
  26
  27 ;; This is a ClearCase/Emacs integration.
  28 ;;
  29 ;;
  30 ;; How to use
  31 ;; ==========
  32 ;;
  33 ;;   0. Make sure you're using Gnu Emacs-20.4 or later or a recent XEmacs.
  34 ;;      In general it seems to work better in Gnu Emacs than in XEmacs,
  35 ;;      although many XEmacs users have no problems at all with it.
  36 ;;
  37 ;;   1. Make sure that you DON'T load old versions of vc-hooks.el which contain
  38 ;;      incompatible versions of the tq package (functions tq-enqueue and
  39 ;;      friends). In particular, Bill Sommerfeld's VC/CC integration has this
  40 ;;      problem.
  41 ;;
  42 ;;   2. Copy the files (or at least the clearcase.elc file) to a directory
  43 ;;      on your emacs-load-path.
  44 ;;
  45 ;;   3. Insert this in your emacs startup file:  (load "clearcase")
  46 ;;
  47 ;; When you begin editing in any view-context, a ClearCase menu will appear
  48 ;; and ClearCase Minor Mode will be activated for you.
  49 ;;
  50 ;; Summary of features
  51 ;; ===================
  52 ;;
  53 ;;   Keybindings compatible with Emacs' VC (where it makes sense)
  54 ;;   Richer interface than VC
  55 ;;   Works on NT and Unix
  56 ;;   Context sensitive menu (Emacs knows the ClearCase-status of files)
  57 ;;   Snapshot view support: update, version comparisons
  58 ;;   Can use Emacs Ediff for version comparison display
  59 ;;   Dired Mode:
  60 ;;     - en masse checkin/out etc
  61 ;;     - enhanced display
  62 ;;     - browse version tree
  63 ;;   Completion of viewnames, version strings
  64 ;;   Auto starting of views referenced as /view/TAG/.. (or \\view\TAG\...)
  65 ;;   Emacs for editing comments, config specs
  66 ;;   Standard ClearCase GUI tools launchable from Emacs menu
  67 ;;     - version tree browser
  68 ;;     - project browser
  69 ;;     - UCM deliver
  70 ;;     - UCM rebase
  71 ;;   Operations directly available from Emacs menu/keymap:
  72 ;;     create-activity
  73 ;;     set-activity
  74 ;;     mkelem,
  75 ;;     checkout
  76 ;;     checkin,
  77 ;;     unco,
  78 ;;     describe
  79 ;;     list history
  80 ;;     edit config spec
  81 ;;     mkbrtype
  82 ;;     snapshot view update: file, directory, view
  83 ;;     version comparisons using ediff, diff or GUI
  84 ;;     find checkouts
  85 ;;     annotate version
  86 ;;     et al.
  87 ;;
  88 ;; Acknowledgements
  89 ;; ================
  90 ;;
  91 ;; The help of the following is gratefully acknowledged:
  92 ;;
  93 ;;   XEmacs support and other bugfixes:
  94 ;;
  95 ;;     Rod Whitby
  96 ;;     Adrian Aichner
  97 ;;
  98 ;;   This was a result of examining earlier versions of VC and VC/ClearCase
  99 ;;   integrations and borrowing freely therefrom.  Accordingly, the following
 100 ;;   are ackowledged as contributors:
 101 ;;
 102 ;;   VC/ClearCase integration authors:
 103 ;;
 104 ;;     Bill Sommerfeld
 105 ;;     Rod Whitby
 106 ;;     Andrew Markebo
 107 ;;     Andy Eskilsson
 108 ;;     Paul Smith
 109 ;;     John Kohl
 110 ;;     Chris Felaco
 111 ;;
 112 ;;   VC authors:
 113 ;;
 114 ;;     Eric S. Raymond
 115 ;;     Andre Spiegel
 116 ;;     Sebastian Kremer
 117 ;;     Richard Stallman
 118 ;;     Per Cederqvist
 119 ;;     ttn@netcom.com
 120 ;;     Andre Spiegel
 121 ;;     Jonathan Stigelman
 122 ;;     Steve Baur
 123 ;;
 124 ;;   Other Contributors:
 125 ;;
 126 ;;     Alastair Rankine
 127 ;;     Andrew Maguire
 128 ;;     Barnaby Dalton
 129 ;;     Christian Savard
 130 ;;     David O'Shea
 131 ;;     Dee Zsombor
 132 ;;     Gabor Zoka
 133 ;;     Jason Rumney
 134 ;;     Jeff Phillips
 135 ;;     Justin Vallon
 136 ;;     Mark Collins
 137 ;;     Patrik Madison
 138 ;;     Ram Bhamidipaty
 139 ;;     Reinhard Hahn
 140 ;;     Richard Kim
 141 ;;     Richard Y. Kim
 142 ;;     Simon Graham
 143 ;;     Stephen Leake
 144 ;;     Steven E. Harris
 145 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 146
 147 ;;}}}
 148
 149 ;;{{{ Version info
 150
 151 (defconst clearcase-version-stamp "ClearCase-version: </main/laptop/156>")
 152 (defconst clearcase-version (substring clearcase-version-stamp 19))
 153
 154 (defun clearcase-maintainer-address ()
 155   ;; Avoid spam.
 156   ;;
 157   (concat "kevin.esler.1989"
 158           "@"
 159           "alum.bu.edu"))
 160
 161 (defun clearcase-submit-bug-report ()
 162   "Submit via mail a bug report on ClearCase Mode"
 163   (interactive)
 164   (and (y-or-n-p "Do you really want to submit a report on ClearCase Mode ? ")
 165        (reporter-submit-bug-report
 166         (clearcase-maintainer-address)
 167         (concat "clearcase.el " clearcase-version)
 168         '(
 169           system-type
 170           system-configuration
 171           emacs-version
 172           clearcase-clearcase-version-installed
 173           clearcase-cleartool-path
 174           clearcase-lt
 175           clearcase-v3
 176           clearcase-v4
 177           clearcase-v5
 178           clearcase-v6
 179           clearcase-servers-online
 180           clearcase-disable-tq
 181           clearcase-on-cygwin
 182           clearcase-setview-root
 183           clearcase-suppress-vc-within-mvfs
 184           shell-file-name
 185           w32-quote-process-args
 186           ))))
 187
 188 ;;}}}
 189
 190 ;;{{{ Macros
 191
 192 (defmacro clearcase-when-debugging (&rest forms)
 193   (list 'if 'clearcase-debug (cons 'progn forms)))
 194
 195 (defmacro clearcase-with-tempfile (filename-var &rest forms)
 196   `(let ((,filename-var (clearcase-utl-tempfile-name)))
 197      (unwind-protect
 198          ,@forms
 199
 200        ;; Cleanup.
 201        ;;
 202        (if (file-exists-p ,filename-var)
 203            (delete-file ,filename-var)))))
 204
 205 ;;}}}
 206
 207 ;;{{{ Portability
 208
 209 (defvar clearcase-xemacs-p (string-match "XEmacs" emacs-version))
 210
 211 (defvar clearcase-on-mswindows (memq system-type
 212                                      '(windows-nt ms-windows cygwin cygwin32)))
 213
 214 (defvar clearcase-on-cygwin (memq system-type '(cygwin cygwin32)))
 215
 216 (defvar clearcase-sink-file-name
 217   (cond
 218    (clearcase-on-cygwin "/dev/null")
 219    (clearcase-on-mswindows "NUL")
 220    (t "/dev/null")))
 221
 222 (defun clearcase-view-mode-quit (buf)
 223   "Exit from View mode, restoring the previous window configuration."
 224   (progn
 225     (cond ((frame-property (selected-frame) 'clearcase-view-window-config)
 226            (set-window-configuration
 227             (frame-property (selected-frame) 'clearcase-view-window-config))
 228            (set-frame-property  (selected-frame) 'clearcase-view-window-config nil))
 229           ((not (one-window-p))
 230            (delete-window)))
 231     (kill-buffer buf)))
 232
 233 (defun clearcase-view-mode (arg &optional camefrom)
 234   (if clearcase-xemacs-p
 235       (let* ((winconfig (current-window-configuration))
 236              (was-one-window (one-window-p))
 237              (buffer-name (buffer-name (current-buffer)))
 238              (clearcase-view-not-visible
 239               (not (and (windows-of-buffer buffer-name) ;shortcut
 240                         (memq (selected-frame)
 241                               (mapcar 'window-frame
 242                                       (windows-of-buffer buffer-name)))))))
 243         (when clearcase-view-not-visible
 244           (set-frame-property (selected-frame)
 245                               'clearcase-view-window-config winconfig))
 246         (view-mode camefrom 'clearcase-view-mode-quit)
 247         (setq buffer-read-only nil))
 248     (view-mode arg)))
 249
 250 (defun clearcase-port-view-buffer-other-window (buffer)
 251   (if clearcase-xemacs-p
 252       (switch-to-buffer-other-window buffer)
 253     (view-buffer-other-window buffer nil 'kill-buffer)))
 254
 255 (defun clearcase-dired-sort-by-date ()
 256   (if (fboundp 'dired-sort-by-date)
 257       (dired-sort-by-date)))
 258
 259 ;; Copied from emacs-20
 260 ;;
 261 (if (not (fboundp 'subst-char-in-string))
 262     (defun subst-char-in-string (fromchar tochar string &optional inplace)
 263       "Replace FROMCHAR with TOCHAR in STRING each time it occurs.
 264 Unless optional argument INPLACE is non-nil, return a new string."
 265       (let ((i (length string))
 266             (newstr (if inplace string (copy-sequence string))))
 267         (while (> i 0)
 268           (setq i (1- i))
 269           (if (eq (aref newstr i) fromchar)
 270               (aset newstr i tochar)))
 271         newstr)))
 272
 273 ;;}}}
 274
 275 ;;{{{ Require calls
 276
 277 ;; nyi: we also use these at the moment:
 278 ;;     -view
 279 ;;     -ediff
 280 ;;     -view
 281 ;;     -dired-sort
 282
 283 (require 'cl)
 284 (require 'comint)
 285 (require 'dired)
 286 (require 'easymenu)
 287 (require 'executable)
 288 (require 'reporter)
 289 (require 'ring)
 290 (or clearcase-xemacs-p
 291     (require 'timer))
 292
 293 ;; NT Emacs - doesn't use tq.
 294 ;;
 295 (if (not clearcase-on-mswindows)
 296     (require 'tq))
 297
 298 ;;}}}
 299
 300 ;;{{{ Debugging facilities
 301
 302 ;; Setting this to true will enable some debug code.
 303 ;;
 304 (defvar clearcase-debug nil)
 305
 306 (defun clearcase-trace (string)
 307   (clearcase-when-debugging
 308    (let ((trace-buf (get-buffer "*clearcase-trace*")))
 309      (if trace-buf
 310          (save-excursion
 311            (set-buffer trace-buf)
 312            (goto-char (point-max))
 313            (insert string "\n"))))))
 314
 315 (defun clearcase-enable-tracing ()
 316   (interactive)
 317   (setq clearcase-debug t)
 318   (get-buffer-create "*clearcase-trace*"))
 319
 320 (defun clearcase-disable-tracing ()
 321   (interactive)
 322   (setq clearcase-debug nil))
 323
 324 (defun clearcase-dump ()
 325   (interactive)
 326   (clearcase-utl-populate-and-view-buffer
 327    "*clearcase-dump*"
 328    nil
 329    (function (lambda ()
 330                (clearcase-fprop-dump-to-current-buffer)
 331                (clearcase-vprop-dump-to-current-buffer)))))
 332
 333 (defun clearcase-flush-caches ()
 334   (interactive)
 335   (clearcase-fprop-clear-all-properties)
 336   (clearcase-vprop-clear-all-properties))
 337
 338 ;;}}}
 339
 340 ;;{{{ Customizable variables
 341
 342 (eval-and-compile
 343   (condition-case nil
 344       (require 'custom)
 345     (error nil))
 346   (if (and (featurep 'custom)
 347            (fboundp 'custom-declare-variable))
 348       nil ;; We've got what we needed
 349     ;; We have the old custom-library, hack around it!
 350     (defmacro defgroup (&rest args)
 351       nil)
 352     (defmacro defcustom (var value doc &rest args)
 353       (` (defvar (, var) (, value) (, doc))))
 354     (defmacro defface (face value doc &rest stuff)
 355       `(make-face ,face))
 356     (defmacro custom-declare-variable (symbol value doc &rest args)
 357       (list 'defvar (eval symbol) value doc))))
 358
 359 (defgroup clearcase () "ClearCase Options" :group 'tools :prefix "clearcase")
 360
 361 (defcustom clearcase-keep-uncheckouts t
 362   "When true, the contents of an undone checkout will be kept in a file
 363 with a \".keep\" suffix. Otherwise it will be removed."
 364   :group 'clearcase
 365   :type 'boolean)
 366
 367 (defcustom clearcase-keep-unhijacks t
 368   "When true, the contents of an undone hijack will be kept in a file
 369 with a \".keep\" suffix. Otherwise it will be removed."
 370   :group 'clearcase
 371   :type 'boolean)
 372
 373 ;; nyi: We could also allow a value of 'prompt here
 374 ;;
 375 (defcustom clearcase-set-to-new-activity t
 376   "*If this variable is non-nil when a new activity is created, that activity
 377 will be set as the current activity for the view, otherwise no change is made
 378 to the view's current activity setting."
 379   :group 'clearcase
 380   :type 'boolean)
 381
 382 (defcustom clearcase-prompt-for-activity-names t
 383   "*If this variable is non-nil the user will be prompted for activity names.
 384 Otherwise, activity names will be generated automatically and will typically
 385 have the form \"activity011112.155233\". If the name entered is empty sucn an
 386 internal name will also be generated."
 387   :group 'clearcase
 388   :type 'boolean)
 389
 390 (defcustom clearcase-make-backup-files nil
 391   "*If non-nil, backups of ClearCase files are made as with other files.
 392 If nil (the default), files under ClearCase control don't get backups."
 393   :group 'clearcase
 394   :type 'boolean)
 395
 396 (defcustom clearcase-complete-viewtags t
 397   "*If non-nil, completion on viewtags is enabled. For sites with thousands of view
 398 this should be set to nil."
 399   :group 'clearcase
 400   :type 'boolean)
 401
 402 (defcustom clearcase-minimise-menus nil
 403   "*If non-nil, menus will hide rather than grey-out inapplicable choices."
 404   :group 'clearcase
 405   :type 'boolean)
 406
 407 (defcustom clearcase-auto-dired-mode t
 408   "*If non-nil, automatically enter `clearcase-dired-mode' in dired-mode
 409 for directories in ClearCase."
 410   :group 'clearcase
 411   :type 'boolean)
 412
 413 (defcustom clearcase-dired-highlight t
 414   "If non-nil, highlight reserved files in clearcase-dired buffers."
 415   :group 'clearcase
 416   :type 'boolean)
 417
 418 (defcustom clearcase-dired-show-view t
 419   "If non-nil, show the view tag in dired buffers."
 420   :group 'clearcase
 421   :type 'boolean)
 422
 423 (defcustom clearcase-verify-pre-mkelem-dir-checkout nil
 424   "*If non-nil, prompt before checking out the containing directory
 425 before creating a new ClearCase element."
 426   :group 'clearcase
 427   :type 'boolean)
 428
 429 (defcustom clearcase-diff-on-checkin nil
 430   "Display diff on checkin to help you compose the checkin comment."
 431   :group 'clearcase
 432   :type 'boolean)
 433
 434 ;; General customization
 435
 436 (defcustom clearcase-suppress-confirm nil
 437   "If non-nil, treat user as expert; suppress yes-no prompts on some things."
 438   :group 'clearcase
 439   :type 'boolean)
 440
 441 (defcustom clearcase-initial-mkelem-comment nil
 442   "Prompt for initial comment when an element is created."
 443   :group 'clearcase
 444   :type 'boolean)
 445
 446 (defcustom clearcase-command-messages nil
 447   "Display run messages from back-end commands."
 448   :group 'clearcase
 449   :type 'boolean)
 450
 451 (defcustom clearcase-checkin-arguments
 452   ;; For backwards compatibility with old name for this variable:
 453   ;;
 454   (if (and (boundp 'clearcase-checkin-switches)
 455            (not (null clearcase-checkin-switches)))
 456       (list clearcase-checkin-switches)
 457     nil)
 458   "A list of extra arguments passed to the checkin command."
 459   :group 'clearcase
 460   :type '(repeat (string :tag "Argument")))
 461
 462 (defcustom clearcase-checkin-on-mkelem nil
 463   "If t, file will be checked-in when first created as an element."
 464   :group 'clearcase
 465   :type 'boolean)
 466
 467 (defcustom clearcase-suppress-checkout-comments nil
 468   "Suppress prompts for checkout comments for those version control
 469 systems which use them."
 470   :group 'clearcase
 471   :type 'boolean)
 472
 473 (defcustom clearcase-checkout-arguments
 474   ;; For backwards compatibility with old name for this variable:
 475   ;;
 476   (if (and (boundp 'clearcase-checkout-arguments)
 477            (not (null clearcase-checkout-arguments)))
 478       (list clearcase-checkout-arguments)
 479     nil)
 480   "A list of extra arguments passed to the checkout command."
 481   :group 'clearcase
 482   :type '(repeat (string :tag "Argument")))
 483
 484 (defcustom clearcase-directory-exclusion-list '("lost+found")
 485   "Directory names ignored by functions that recursively walk file trees."
 486   :group 'clearcase
 487   :type '(repeat (string :tag "Subdirectory")))
 488
 489 (defcustom clearcase-use-normal-diff nil
 490   "If non-nil, use normal diff instead of cleardiff."
 491   :group 'clearcase
 492   :type 'boolean)
 493
 494 (defcustom clearcase-normal-diff-program "diff"
 495   "*Program to use for generating the differential of the two files
 496 when `clearcase-use-normal-diff' is t."
 497   :group 'clearcase
 498   :type 'string)
 499
 500 (defcustom clearcase-normal-diff-arguments
 501   (if (and (boundp 'clearcase-normal-diff-switches)
 502            (not (null clearcase-normal-diff-switches)))
 503       (list clearcase-normal-diff-switches)
 504     (list "-u"))
 505   "A list of extra arguments passed to `clearcase-normal-diff-program'
 506 when `clearcase-use-normal-diff' is t.  Usage of the -u switch is
 507 recommended to produce unified diffs, when your
 508 `clearcase-normal-diff-program' supports it."
 509   :group 'clearcase
 510   :type '(repeat (string :tag "Argument")))
 511
 512 (defcustom clearcase-vxpath-glue "@@"
 513   "The string used to construct version-extended pathnames."
 514   :group 'clearcase
 515   :type 'string)
 516
 517 (defcustom clearcase-viewroot (if clearcase-on-mswindows
 518                                   "//view"
 519                                 "/view")
 520   "The ClearCase viewroot directory."
 521   :group 'clearcase
 522   :type 'file)
 523
 524 (defcustom clearcase-viewroot-drive "m:"
 525   "The ClearCase viewroot drive letter for Windows."
 526   :group 'clearcase
 527   :type 'string)
 528
 529 (defcustom clearcase-suppress-vc-within-mvfs t
 530   "Suppresses VC activity within the MVFS."
 531   :group 'clearcase
 532   :type 'boolean)
 533
 534 (defcustom clearcase-hide-rebase-activities t
 535   "Hide rebase activities from activity selection list."
 536   :group 'clearcase
 537   :type 'boolean)
 538
 539 (defcustom clearcase-rebase-id-regexp "^rebase\\."
 540   "The regexp used to detect rebase actvities."
 541   :group 'clearcase
 542   :type 'string)
 543
 544 ;;}}}
 545
 546 ;;{{{ Global variables
 547
 548 ;; Initialize clearcase-pname-sep-regexp according to
 549 ;; directory-sep-char.
 550 (defvar clearcase-pname-sep-regexp
 551   (format "[%s/]"
 552           (char-to-string directory-sep-char)))
 553
 554 (defvar clearcase-non-pname-sep-regexp
 555   (format "[^%s/]"
 556           (char-to-string directory-sep-char)))
 557
 558 ;; Matches any viewtag (without the trailing "/").
 559 ;;
 560 (defvar clearcase-viewtag-regexp
 561   (concat "^"
 562           clearcase-viewroot
 563           clearcase-pname-sep-regexp
 564           "\\("
 565           clearcase-non-pname-sep-regexp "*"
 566           "\\)"
 567           "$"
 568           ))
 569
 570 ;; Matches ANY viewroot-relative path
 571 ;;
 572 (defvar clearcase-vrpath-regexp
 573   (concat "^"
 574           clearcase-viewroot
 575           clearcase-pname-sep-regexp
 576           "\\("
 577           clearcase-non-pname-sep-regexp "*"
 578           "\\)"
 579           ))
 580
 581 ;;}}}
 582
 583 ;;{{{ Minor Mode: ClearCase
 584
 585 ;; For ClearCase Minor Mode
 586 ;;
 587 (defvar clearcase-mode nil)
 588 (set-default 'clearcase-mode nil)
 589 (make-variable-buffer-local 'clearcase-mode)
 590 (put 'clearcase-mode 'permanent-local t)
 591
 592 ;; Tell Emacs about this new kind of minor mode
 593 ;;
 594 (if (not (assoc 'clearcase-mode minor-mode-alist))
 595     (setq minor-mode-alist (cons '(clearcase-mode clearcase-mode)
 596                                  minor-mode-alist)))
 597
 598 ;; For now we override the bindings for VC Minor Mode with ClearCase Minor Mode
 599 ;; bindings.
 600 ;;
 601 (defvar clearcase-mode-map (make-sparse-keymap))
 602 (defvar clearcase-prefix-map (make-sparse-keymap))
 603 (define-key clearcase-mode-map "\C-xv" clearcase-prefix-map)
 604 (define-key clearcase-mode-map "\C-x\C-q" 'clearcase-toggle-read-only)
 605
 606 (define-key clearcase-prefix-map "b" 'clearcase-browse-vtree-current-buffer)
 607 (define-key clearcase-prefix-map "c" 'clearcase-uncheckout-current-buffer)
 608 (define-key clearcase-prefix-map "e" 'clearcase-edcs-edit)
 609 (define-key clearcase-prefix-map "g" 'clearcase-annotate-current-buffer)
 610 (define-key clearcase-prefix-map "i" 'clearcase-mkelem-current-buffer)
 611 (define-key clearcase-prefix-map "l" 'clearcase-list-history-current-buffer)
 612 (define-key clearcase-prefix-map "m" 'clearcase-mkbrtype)
 613 (define-key clearcase-prefix-map "u" 'clearcase-uncheckout-current-buffer)
 614 (define-key clearcase-prefix-map "v" 'clearcase-next-action-current-buffer)
 615 (define-key clearcase-prefix-map "w" 'clearcase-what-rule-current-buffer)
 616 (define-key clearcase-prefix-map "=" 'clearcase-diff-pred-current-buffer)
 617 (define-key clearcase-prefix-map "?" 'clearcase-describe-current-buffer)
 618 (define-key clearcase-prefix-map "~" 'clearcase-version-other-window)
 619
 620 ;; To avoid confusion, we prevent VC Mode from being active at all by
 621 ;; undefining its keybindings for which ClearCase Mode doesn't yet have an
 622 ;; analogue.
 623 ;;
 624 (define-key clearcase-prefix-map "a" 'undefined) ;; vc-update-change-log
 625 (define-key clearcase-prefix-map "d" 'undefined) ;; vc-directory
 626 (define-key clearcase-prefix-map "h" 'undefined) ;; vc-insert-headers
 627 (define-key clearcase-prefix-map "m" 'undefined) ;; vc-merge
 628 (define-key clearcase-prefix-map "r" 'undefined) ;; vc-retrieve-snapshot
 629 (define-key clearcase-prefix-map "s" 'undefined) ;; vc-create-snapshot
 630 (define-key clearcase-prefix-map "t" 'undefined) ;; vc-dired-toggle-terse-mode
 631
 632 ;; Associate the map and the minor mode
 633 ;;
 634 (or (not (boundp 'minor-mode-map-alist))
 635     (assq 'clearcase-mode (symbol-value 'minor-mode-map-alist))
 636     (setq minor-mode-map-alist
 637           (cons (cons 'clearcase-mode clearcase-mode-map)
 638                 minor-mode-map-alist)))
 639
 640 (defun clearcase-mode (&optional arg)
 641   "ClearCase Minor Mode"
 642
 643   (interactive "P")
 644
 645   ;; Behave like a proper minor-mode.
 646   ;;
 647   (setq clearcase-mode
 648         (if (interactive-p)
 649             (if (null arg)
 650                 (not clearcase-mode)
 651
 652               ;; Check if the numeric arg is positive.
 653               ;;
 654               (> (prefix-numeric-value arg) 0))
 655
 656           ;; else
 657           ;; Use the car if it's a list.
 658           ;;
 659           (if (consp arg)
 660               (setq arg (car arg)))
 661           (if (symbolp arg)
 662               (if (null arg)
 663                   (not clearcase-mode) ;; toggle mode switch
 664                 (not (eq '- arg))) ;; True if symbol is not '-
 665
 666             ;; else
 667             ;; assume it's a number and check that.
 668             ;;
 669             (> arg 0))))
 670
 671   (if clearcase-mode
 672       (easy-menu-add clearcase-menu 'clearcase-mode-map))
 673   )
 674
 675 ;;}}}
 676
 677 ;;{{{ Minor Mode: ClearCase Dired
 678
 679 ;;{{{ Reformatting the Dired buffer
 680
 681 ;; Create a face for highlighting checked out files in clearcase-dired.
 682 ;;
 683 (if (not (memq 'clearcase-dired-checkedout-face (face-list)))
 684     (progn
 685       (make-face 'clearcase-dired-checkedout-face)
 686       (set-face-foreground 'clearcase-dired-checkedout-face "red")))
 687
 688 (defun clearcase-dired-insert-viewtag ()
 689   (save-excursion
 690     (progn
 691       (goto-char (point-min))
 692
 693       ;; Only do this if the buffer is not currently narrowed
 694       ;;
 695       (if (= 1 (point))
 696           (let ((viewtag (clearcase-fprop-viewtag (file-truename default-directory))))
 697             (if viewtag
 698                 (progn
 699                   (forward-line 1)
 700                   (let ((buffer-read-only nil))
 701                     (insert (format "  [ClearCase View: %s]\n" viewtag))))))))))
 702
 703 (defun clearcase-dired-reformat-buffer ()
 704   "Reformats the current dired buffer."
 705   (let* ((checkout-list nil)
 706          (modified-file-info nil)
 707          (hijack-list nil)
 708          (directory default-directory)
 709          subdir
 710          fullpath)
 711
 712     ;; Iterate over each line in the buffer.
 713     ;;
 714     ;; Important notes:
 715     ;;   1. In general, a Dired buffer can contain listings for several
 716     ;;        directories. We pass though from top to bottom and adjust
 717     ;;        subdir as we go.
 718     ;;   2. Since this is called from dired-after-reading-hook, it can get
 719     ;;      called on a single-line buffer. In this case there is no subdir,
 720     ;;      and no checkout-list. We need to call clearcase-fprop-checked-out
 721     ;;      to test for a checkout.
 722     ;;
 723     (save-excursion
 724       (goto-char (point-min))
 725       (while (not (eobp))
 726         (cond
 727
 728          ;; Case 1: Look for directory markers
 729          ;;
 730          ((setq subdir (dired-get-subdir))
 731
 732           ;; We're at a subdirectory line in the dired buffer.
 733           ;; Go and list all checkouts and hijacks in this subdirectory.
 734           ;;
 735           (setq modified-file-info (clearcase-dired-list-modified-files subdir))
 736           (setq checkout-list (nth 0 modified-file-info))
 737           (setq hijack-list (nth 1 modified-file-info))
 738
 739           ;; If no checkouts are found, we don't need to check each file, and
 740           ;; it's very slow.  The checkout-list should contain something so it
 741           ;; doesn't attempt to do this.
 742           ;;
 743           (if (null checkout-list)
 744               (setq checkout-list '(nil)))
 745           (if (null hijack-list)
 746               (setq hijack-list '(nil)))
 747           (message "Reformatting %s..." subdir))
 748
 749          ;; Case 2: Look for files (the safest way to get the filename).
 750          ;;
 751          ((setq fullpath (dired-get-filename nil t))
 752
 753           ;; Expand it to get rid of . and .. entries.
 754           ;;
 755           (setq fullpath (expand-file-name fullpath))
 756
 757           (setq fullpath (clearcase-path-canonicalise-slashes fullpath))
 758
 759           ;; Only modify directory listings of the correct format.
 760           ;; We replace the GID field with a checkout indicator.
 761           ;;
 762           (if (looking-at
 763                ;;     (1)     (2) (3)    (4)
 764                ;; -rw-rw-rw-   1 esler    5              28 Feb  2 16:02 foo.el
 765                "..\\([drwxlts-]+ \\) *\\([0-9]+\\) \\([^ ]+\\) *\\([^ ]+ *\\) +[0-9]+\\( [^ 0-9]+ [0-9 ][0-9] .*\\)")
 766
 767               (let* ((replacement-begin (match-beginning 4))
 768                      (replacement-end (match-end 4))
 769
 770                      (replacement-length (- replacement-end replacement-begin))
 771                      (checkout-replacement-text (format "CHECKOUT"))
 772                      (hijack-replacement-text (format "HIJACK"))
 773                      (is-checkout (if checkout-list
 774                                       (member fullpath checkout-list)
 775                                     (clearcase-fprop-checked-out fullpath)))
 776                      (is-hijack (if hijack-list
 777                                       (member fullpath hijack-list)
 778                                     (clearcase-fprop-hijacked fullpath))))
 779
 780                 ;; Highlight the line if the file is checked-out.
 781                 ;;
 782                 (if is-checkout
 783                     (progn
 784                       ;; Replace the GID field with CHECKOUT.
 785                       ;;
 786                       (let ((buffer-read-only nil))
 787
 788                         ;; Pad with replacement text with trailing spaces if necessary.
 789                         ;;
 790                         (if (>= replacement-length (length checkout-replacement-text))
 791                             (setq checkout-replacement-text
 792                                   (concat checkout-replacement-text
 793                                           (make-string (- replacement-length (length checkout-replacement-text))
 794                                                        32))))
 795                         (goto-char replacement-begin)
 796                         (delete-char replacement-length)
 797                         (insert (substring checkout-replacement-text 0 replacement-length)))
 798
 799                       ;; Highlight the checked out files.
 800                       ;;
 801                       (if (fboundp 'put-text-property)
 802                           (let ((buffer-read-only nil))
 803                             (put-text-property replacement-begin replacement-end
 804                                                'face 'clearcase-dired-checkedout-face)))
 805                       )
 806                   )
 807
 808                 (if is-hijack
 809                     (progn
 810                       ;; Replace the GID field with CHECKOUT.
 811                       ;;
 812                       (let ((buffer-read-only nil))
 813
 814                         ;; Pad with replacement text with trailing spaces if necessary.
 815                         ;;
 816                         (if (>= replacement-length (length hijack-replacement-text))
 817                             (setq hijack-replacement-text
 818                                   (concat hijack-replacement-text
 819                                           (make-string (- replacement-length (length hijack-replacement-text))
 820                                                        32))))
 821                         (goto-char replacement-begin)
 822                         (delete-char replacement-length)
 823                         (insert (substring hijack-replacement-text 0 replacement-length)))
 824
 825                       ;; Highlight the checked out files.
 826                       ;;
 827                       (if (fboundp 'put-text-property)
 828                           (let ((buffer-read-only nil))
 829                             (put-text-property replacement-begin replacement-end
 830                                                'face 'clearcase-dired-checkedout-face)))
 831                       )
 832                   )
 833
 834                 ))))
 835         (forward-line 1))))
 836   (message "Reformatting...Done"))
 837
 838
 839 (defun clearcase-path-follow-if-vob-slink (path)
 840   (if (clearcase-fprop-file-is-vob-slink-p path)
 841
 842       ;; It's a slink so follow it.
 843       ;;
 844       (let ((slink-text (clearcase-fprop-vob-slink-text path)))
 845         (if (file-name-absolute-p slink-text)
 846             slink-text
 847           (concat (file-name-directory path) slink-text)))
 848
 849     ;; Not an slink.
 850     ;;
 851     path))
 852
 853 ;;{{{ Searching for modified files
 854
 855 ;;{{{ Old code
 856
 857 ;; (defun clearcase-dired-list-checkouts (directory)
 858 ;;   "Returns a list of files checked-out to the current view in DIRECTORY."
 859
 860 ;;   ;; Don't bother looking for checkouts in
 861 ;;   ;;  - a history-mode branch-qua-directory
 862 ;;   ;;  - a view-private directory
 863 ;;   ;;
 864 ;;   ;; NYI: For now don't run lsco in root of a snapshot because it gives errors.
 865 ;;   ;;      We need to make this smarter.
 866 ;;   ;;
 867 ;;   ;; NYI: For a pathname which is a slink to a dir, despite the fact that
 868 ;;   ;;      clearcase-fprop-file-is-version-p returns true, lsco fails on it,
 869 ;;   ;;      with "not an element". Sheesh, surely lsco ought to follow links ?
 870 ;;   ;;      Solution: catch the error and check if the dir is a slink then follow
 871 ;;   ;;      the link and retry the lsco on the target.
 872 ;;   ;;
 873 ;;   ;;      For now just ignore the error.
 874 ;;   ;;
 875 ;;   (if (and (not (clearcase-vxpath-p directory))
 876 ;;            (not (eq 'view-private-object (clearcase-fprop-mtype directory)))
 877 ;;            (clearcase-fprop-file-is-version-p directory))
 878
 879
 880 ;;       (let* ((ignore (message "Listing ClearCase checkouts..."))
 881
 882 ;;              (true-dir-path (file-truename directory))
 883
 884 ;;              ;; Give the directory as an argument so all names will be
 885 ;;              ;; fullpaths. For some reason ClearCase adds an extra slash if you
 886 ;;              ;; leave the trailing slash on the directory, so we need to remove
 887 ;;              ;; it.
 888 ;;              ;;
 889 ;;              (native-dir-path (clearcase-path-native (directory-file-name true-dir-path)))
 890
 891 ;;              (followed-dir-path (clearcase-path-follow-if-vob-slink native-dir-path))
 892
 893 ;;              ;; Form the command:
 894 ;;              ;;
 895 ;;              (cmd (list
 896 ;;                    "lsco" "-cview" "-fmt"
 897 ;;                    (if clearcase-on-mswindows
 898 ;;                        "%n\\n"
 899 ;;                      "'%n\\n'")
 900
 901 ;;                    followed-dir-path))
 902
 903 ;;              ;; Capture the output:
 904 ;;              ;;
 905 ;;              (string (clearcase-path-canonicalise-slashes
 906 ;;                       (apply 'clearcase-ct-cleartool-cmd cmd)))
 907
 908 ;;              ;; Split the output at the newlines:
 909 ;;              ;;
 910 ;;              (checkout-list (clearcase-utl-split-string-at-char string ?\n)))
 911
 912 ;;         ;; Add entries for "." and ".." if they're checked-out.
 913 ;;         ;;
 914 ;;         (let* ((entry ".")
 915 ;;                (path (expand-file-name (concat (file-name-as-directory true-dir-path)
 916 ;;                                                entry))))
 917 ;;           (if (clearcase-fprop-checked-out path)
 918 ;;               (setq checkout-list (cons path checkout-list))))
 919 ;;         (let* ((entry "..")
 920 ;;                (path (expand-file-name (concat (file-name-as-directory true-dir-path)
 921 ;;                                                entry))))
 922 ;;           (if (clearcase-fprop-checked-out path)
 923 ;;               (setq checkout-list (cons path checkout-list))))
 924
 925 ;;         ;; If DIRECTORY is a vob-slink, checkout list will contain pathnames
 926 ;;         ;; relative to the vob-slink target rather than to DIRECTORY.  Convert
 927 ;;         ;; them back here.  We're making it appear that lsco works on
 928 ;;         ;; slinks-to-dirs.
 929 ;;         ;;
 930 ;;         (if (clearcase-fprop-file-is-vob-slink-p true-dir-path)
 931 ;;             (let ((re (regexp-quote (file-name-as-directory followed-dir-path))))
 932 ;;               (setq checkout-list
 933 ;;                     (mapcar
 934 ;;                      (function
 935 ;;                       (lambda (path)
 936 ;;                         (replace-regexp-in-string re true-dir-path path)))
 937 ;;                      checkout-list))))
 938
 939 ;;         (message "Listing ClearCase checkouts...done")
 940
 941 ;;         ;; Return the result.
 942 ;;         ;;
 943 ;;         checkout-list)
 944 ;;     ))
 945
 946 ;; ;; I had believed that this implementation below OUGHT to be faster, having
 947 ;; ;; read the code in "ct+lsco". It seemed that "lsco -cview" hit the VOB and
 948 ;; ;; listed all checkouts on all elements in the directory, and then filtered by
 949 ;; ;; view.  I thought it would probably be quicker to run "ct ls -vob_only" and
 950 ;; ;; keep the lines that have "[eclipsed by checkout]".  However this code
 951 ;; ;; actually seemed to run slower.  Leave the code here for now so I can test
 952 ;; ;; further.
 953 ;; ;;
 954 ;; (defun clearcase-dired-list-checkouts-experimental (directory)
 955 ;;   "Returns a list of files checked-out to the current view in DIRECTORY."
 956
 957 ;;   ;; Don't bother looking for checkouts in a history-mode listing
 958 ;;   ;; nor in view-private directories.
 959 ;;   ;;
 960 ;;   (if (and (not (clearcase-vxpath-p directory))
 961 ;;            (not (eq 'view-private-object (clearcase-fprop-mtype directory))))
 962
 963 ;;       (let* ((ignore (message "Listing ClearCase checkouts..."))
 964
 965 ;;              (true-directory (file-truename directory))
 966
 967 ;;              ;; Move temporarily to the directory:
 968 ;;              ;;
 969 ;;              (default-directory true-directory)
 970
 971 ;;              ;; Form the command:
 972 ;;              ;;
 973 ;;              (cmd (list "ls" "-vob_only"))
 974
 975 ;;              ;; Capture the output:
 976 ;;              ;;
 977 ;;              (string (clearcase-path-canonicalise-slashes
 978 ;;                       (apply 'clearcase-ct-cleartool-cmd cmd)))
 979
 980 ;;              ;; Split the output at the newlines:
 981 ;;              ;;
 982 ;;              (line-list (clearcase-utl-split-string-at-char string ?\n))
 983
 984 ;;              (checkout-list nil))
 985
 986 ;;         ;; Look for lines of the form:
 987 ;;         ;; FILENAME@@ [eclipsed by checkout]
 988 ;;         ;;
 989 ;;         (mapcar (function
 990 ;;                  (lambda (line)
 991 ;;                    (if (string-match "^\\([^ @]+\\)@@ +\\[eclipsed by checkout\\].*" line)
 992 ;;                        (setq checkout-list (cons (concat
 993 ;;                                                   ;; Add back directory name to get
 994 ;;                                                   ;; full pathname.
 995 ;;                                                   ;;
 996 ;;                                                   default-directory
 997 ;;                                                   (substring line
 998 ;;                                                              (match-beginning 1)
 999 ;;                                                              (match-end 1)))
1000 ;;                                                  checkout-list)))))
1001 ;;                 line-list)
1002
1003 ;;         ;; Add entries for "." and ".." if they're checked-out.
1004 ;;         ;;
1005 ;;         (let* ((entry ".")
1006 ;;                (path (expand-file-name (concat true-directory entry))))
1007 ;;           (if (clearcase-fprop-checked-out path)
1008 ;;               (setq checkout-list (cons path checkout-list))))
1009 ;;         (let* ((entry "..")
1010 ;;                (path (expand-file-name (concat true-directory entry))))
1011 ;;           (if (clearcase-fprop-checked-out path)
1012 ;;               (setq checkout-list (cons path checkout-list))))
1013
1014 ;;         (message "Listing ClearCase checkouts...done")
1015
1016 ;;         ;; Return the result.
1017 ;;         ;;
1018 ;;         checkout-list)))
1019
1020 ;; (defun clearcase-dired-list-hijacks (directory)
1021 ;;   "Returns a list of files hijacked to the current view in DIRECTORY."
1022
1023 ;;   ;; Don't bother looking for hijacks in;
1024 ;;   ;;   - a history-mode listing
1025 ;;   ;;   - a in view-private directory
1026 ;;   ;;   - a dynamic view
1027 ;;   ;;
1028 ;;   (let* ((true-directory (file-truename directory))
1029 ;;          (viewtag (clearcase-fprop-viewtag true-directory)))
1030
1031 ;;     (if (and viewtag
1032 ;;              (not (clearcase-vxpath-p directory))
1033 ;;              (not (eq 'view-private-object (clearcase-fprop-mtype directory)))
1034 ;;              (clearcase-file-would-be-in-snapshot-p true-directory))
1035
1036 ;;         (let* ((ignore (message "Listing ClearCase hijacks..."))
1037
1038 ;;                (true-directory (file-truename directory))
1039
1040 ;;                ;; Form the command:
1041 ;;                ;;
1042 ;;                (cmd (list
1043 ;;                      "ls"
1044
1045 ;;                      ;; Give the directory as an argument so all names will be
1046 ;;                      ;; fullpaths. For some reason ClearCase adds an extra slash
1047 ;;                      ;; if you leave the trailing slash on the directory, so we
1048 ;;                      ;; need to remove it.
1049 ;;                      ;;
1050 ;;                      (clearcase-path-native (directory-file-name true-directory))))
1051
1052 ;;                ;; Capture the output:
1053 ;;                ;;
1054 ;;                (string (clearcase-path-canonicalise-slashes
1055 ;;                         (apply 'clearcase-ct-cleartool-cmd cmd)))
1056
1057 ;;                ;; Split the output at the newlines:
1058 ;;                ;;
1059 ;;                (line-list (clearcase-utl-split-string-at-char string ?\n))
1060
1061 ;;                (hijack-list nil))
1062
1063 ;;           (mapcar (function
1064 ;;                    (lambda (line)
1065 ;;                      (if (string-match "^\\([^ @]+\\)@@[^ ]+ \\[hijacked\\].*" line)
1066 ;;                          (setq hijack-list (cons (substring line
1067 ;;                                                             (match-beginning 1)
1068 ;;                                                             (match-end 1))
1069 ;;                                                  hijack-list)))))
1070 ;;                   line-list)
1071
1072 ;;           (message "Listing ClearCase hijacks...done")
1073
1074 ;;           ;; Return the result.
1075 ;;           ;;
1076 ;;           hijack-list))))
1077
1078 ;;}}}
1079
1080 (defun clearcase-dired-list-modified-files (directory)
1081   "Returns a pair of lists of files (checkouts . hijacks) to the current view in DIRECTORY."
1082
1083   ;; Don't bother looking for hijacks in;
1084   ;;   - a history-mode listing
1085   ;;   - a in view-private directory
1086   ;;   - a dynamic view
1087   ;;
1088   (let* ((true-directory (file-truename directory))
1089          (viewtag (clearcase-fprop-viewtag true-directory))
1090          (snapshot (clearcase-file-would-be-in-snapshot-p true-directory))
1091          (result '(() ())))
1092
1093     (if (and viewtag
1094              (not (clearcase-vxpath-p directory))
1095              (not (eq 'view-private-object (clearcase-fprop-mtype directory))))
1096
1097         (let* ((ignore (message "Listing ClearCase modified files..."))
1098
1099                (true-directory (file-truename directory))
1100
1101                ;; Form the command:
1102                ;;
1103                (cmd (list
1104                      "ls"
1105
1106                      ;; Give the directory as an argument so all names will be
1107                      ;; fullpaths. For some reason ClearCase adds an extra slash
1108                      ;; if you leave the trailing slash on the directory, so we
1109                      ;; need to remove it.
1110                      ;;
1111                      (clearcase-path-native (directory-file-name true-directory))))
1112
1113                ;; Capture the output:
1114                ;;
1115                (string (clearcase-path-canonicalise-slashes
1116                         (apply 'clearcase-ct-cleartool-cmd cmd)))
1117
1118                ;; Split the output at the newlines:
1119                ;;
1120                (line-list (clearcase-utl-split-string-at-char string ?\n))
1121
1122                (hijack-list nil)
1123                (checkout-list nil))
1124
1125           (mapcar (function
1126                    (lambda (line)
1127                      (if (string-match "^\\([^ @]+\\)@@[^ ]+ \\[hijacked\\].*" line)
1128                          (setq hijack-list (cons (substring line
1129                                                             (match-beginning 1)
1130                                                             (match-end 1))
1131                                                  hijack-list)))
1132                      (if (string-match "^\\([^ @]+\\)@@.+CHECKEDOUT from .*" line)
1133                          (setq checkout-list (cons (substring line
1134                                                               (match-beginning 1)
1135                                                               (match-end 1))
1136                                                    checkout-list)))))
1137                   line-list)
1138
1139           (message "Listing ClearCase modified files...done")
1140
1141           ;; Return the result.
1142           ;;
1143           (setq result (list checkout-list hijack-list))))
1144     result))
1145
1146 ;;}}}
1147
1148 ;;}}}
1149
1150 ;; For ClearCase Dired Minor Mode
1151 ;;
1152 (defvar clearcase-dired-mode nil)
1153 (set-default 'clearcase-dired-mode nil)
1154 (make-variable-buffer-local 'clearcase-dired-mode)
1155
1156 ;; Tell Emacs about this new kind of minor mode
1157 ;;
1158 (if (not (assoc 'clearcase-dired-mode minor-mode-alist))
1159     (setq minor-mode-alist (cons '(clearcase-dired-mode clearcase-dired-mode)
1160                                  minor-mode-alist)))
1161
1162 ;; For now we override the bindings for VC Minor Mode with ClearCase Dired
1163 ;; Minor Mode bindings.
1164 ;;
1165 (defvar clearcase-dired-mode-map (make-sparse-keymap))
1166 (defvar clearcase-dired-prefix-map (make-sparse-keymap))
1167 (define-key clearcase-dired-mode-map "\C-xv" clearcase-dired-prefix-map)
1168
1169 (define-key clearcase-dired-prefix-map "b" 'clearcase-browse-vtree-dired-file)
1170 (define-key clearcase-dired-prefix-map "c" 'clearcase-uncheckout-dired-files)
1171 (define-key clearcase-dired-prefix-map "e" 'clearcase-edcs-edit)
1172 (define-key clearcase-dired-prefix-map "i" 'clearcase-mkelem-dired-files)
1173 (define-key clearcase-dired-prefix-map "g" 'clearcase-annotate-dired-file)
1174 (define-key clearcase-dired-prefix-map "l" 'clearcase-list-history-dired-file)
1175 (define-key clearcase-dired-prefix-map "m" 'clearcase-mkbrtype)
1176 (define-key clearcase-dired-prefix-map "u" 'clearcase-uncheckout-dired-files)
1177 (define-key clearcase-dired-prefix-map "v" 'clearcase-next-action-dired-files)
1178 (define-key clearcase-dired-prefix-map "w" 'clearcase-what-rule-dired-file)
1179 (define-key clearcase-dired-prefix-map "=" 'clearcase-diff-pred-dired-file)
1180 (define-key clearcase-dired-prefix-map "~" 'clearcase-version-other-window)
1181 (define-key clearcase-dired-prefix-map "?" 'clearcase-describe-dired-file)
1182
1183 ;; To avoid confusion, we prevent VC Mode from being active at all by
1184 ;; undefining its keybindings for which ClearCase Mode doesn't yet have an
1185 ;; analogue.
1186 ;;
1187 (define-key clearcase-dired-prefix-map "a" 'undefined) ;; vc-update-change-log
1188 (define-key clearcase-dired-prefix-map "d" 'undefined) ;; vc-directory
1189 (define-key clearcase-dired-prefix-map "h" 'undefined) ;; vc-insert-headers
1190 (define-key clearcase-dired-prefix-map "m" 'undefined) ;; vc-merge
1191 (define-key clearcase-dired-prefix-map "r" 'undefined) ;; vc-retrieve-snapshot
1192 (define-key clearcase-dired-prefix-map "s" 'undefined) ;; vc-create-snapshot
1193 (define-key clearcase-dired-prefix-map "t" 'undefined) ;; vc-dired-toggle-terse-mode
1194
1195 ;; Associate the map and the minor mode
1196 ;;
1197 (or (not (boundp 'minor-mode-map-alist))
1198     (assq 'clearcase-dired-mode (symbol-value 'minor-mode-map-alist))
1199     (setq minor-mode-map-alist
1200           (cons (cons 'clearcase-dired-mode clearcase-dired-mode-map)
1201                 minor-mode-map-alist)))
1202
1203 (defun clearcase-dired-mode (&optional arg)
1204   "The augmented Dired minor mode used in ClearCase directory buffers.
1205 All Dired commands operate normally.  Users with checked-out files
1206 are listed in place of the file's owner and group. Keystrokes bound to
1207 ClearCase Mode commands will execute as though they had been called
1208 on a buffer attached to the file named in the current Dired buffer line."
1209
1210   (interactive "P")
1211
1212   ;; Behave like a proper minor-mode.
1213   ;;
1214   (setq clearcase-dired-mode
1215         (if (interactive-p)
1216             (if (null arg)
1217                 (not clearcase-dired-mode)
1218
1219               ;; Check if the numeric arg is positive.
1220               ;;
1221               (> (prefix-numeric-value arg) 0))
1222
1223           ;; else
1224           ;; Use the car if it's a list.
1225           ;;
1226           (if (consp arg)
1227               (setq arg (car arg)))
1228
1229           (if (symbolp arg)
1230               (if (null arg)
1231                   (not clearcase-dired-mode) ;; toggle mode switch
1232                 (not (eq '- arg))) ;; True if symbol is not '-
1233
1234             ;; else
1235             ;; assume it's a number and check that.
1236             ;;
1237             (> arg 0))))
1238
1239   (if (not (eq major-mode 'dired-mode))
1240       (setq clearcase-dired-mode nil))
1241
1242   (if (and clearcase-dired-mode clearcase-dired-highlight)
1243       (clearcase-dired-reformat-buffer))
1244
1245   (if clearcase-dired-mode
1246       (easy-menu-add clearcase-dired-menu 'clearcase-dired-mode-map))
1247   )
1248
1249 ;;}}}
1250
1251 ;;{{{ Major Mode: for editing comments.
1252
1253 ;; The major mode function.
1254 ;;
1255 (defun clearcase-comment-mode ()
1256   "Major mode for editing comments for ClearCase.
1257
1258 These bindings are added to the global keymap when you enter this mode:
1259
1260 \\[clearcase-next-action-current-buffer]  perform next logical version-control operation on current file
1261 \\[clearcase-mkelem-current-buffer]       mkelem the current file
1262 \\[clearcase-toggle-read-only]            like next-action, but won't create elements
1263 \\[clearcase-list-history-current-buffer] display change history of current file
1264 \\[clearcase-uncheckout-current-buffer]   cancel checkout in buffer
1265 \\[clearcase-diff-pred-current-buffer]    show diffs between file versions
1266 \\[clearcase-version-other-window]        visit old version in another window
1267
1268 While you are entering a comment for a version, the following
1269 additional bindings will be in effect.
1270
1271 \\[clearcase-comment-finish]           proceed with check in, ending comment
1272
1273 Whenever you do a checkin, your comment is added to a ring of
1274 saved comments.  These can be recalled as follows:
1275
1276 \\[clearcase-comment-next]             replace region with next message in comment ring
1277 \\[clearcase-comment-previous]         replace region with previous message in comment ring
1278 \\[clearcase-comment-search-reverse]   search backward for regexp in the comment ring
1279 \\[clearcase-comment-search-forward]   search backward for regexp in the comment ring
1280
1281 Entry to the clearcase-comment-mode calls the value of text-mode-hook, then
1282 the value of clearcase-comment-mode-hook.
1283
1284 Global user options:
1285  clearcase-initial-mkelem-comment      If non-nil, require user to enter a change
1286                                    comment upon first checkin of the file.
1287
1288  clearcase-suppress-confirm     Suppresses some confirmation prompts,
1289                             notably for reversions.
1290
1291  clearcase-command-messages     If non-nil, display run messages from the
1292                             actual version-control utilities (this is
1293                             intended primarily for people hacking clearcase.el
1294                             itself).
1295 "
1296   (interactive)
1297
1298   ;; Major modes are supposed to just (kill-all-local-variables)
1299   ;; but we rely on clearcase-parent-buffer already having been set
1300   ;;
1301   ;;(let ((parent clearcase-parent-buffer))
1302   ;;  (kill-all-local-variables)
1303   ;;  (set (make-local-variable 'clearcase-parent-buffer) parent))
1304
1305   (setq major-mode 'clearcase-comment-mode)
1306   (setq mode-name "ClearCase/Comment")
1307
1308   (set-syntax-table text-mode-syntax-table)
1309   (use-local-map clearcase-comment-mode-map)
1310   (setq local-abbrev-table text-mode-abbrev-table)
1311
1312   (make-local-variable 'clearcase-comment-operands)
1313   (make-local-variable 'clearcase-comment-ring-index)
1314
1315   (set-buffer-modified-p nil)
1316   (setq buffer-file-name nil)
1317   (run-hooks 'text-mode-hook 'clearcase-comment-mode-hook))
1318
1319 ;; The keymap.
1320 ;;
1321 (defvar clearcase-comment-mode-map nil)
1322 (if clearcase-comment-mode-map
1323     nil
1324   (setq clearcase-comment-mode-map (make-sparse-keymap))
1325   (define-key clearcase-comment-mode-map "\M-n" 'clearcase-comment-next)
1326   (define-key clearcase-comment-mode-map "\M-p" 'clearcase-comment-previous)
1327   (define-key clearcase-comment-mode-map "\M-r" 'clearcase-comment-search-reverse)
1328   (define-key clearcase-comment-mode-map "\M-s" 'clearcase-comment-search-forward)
1329   (define-key clearcase-comment-mode-map "\C-c\C-c" 'clearcase-comment-finish)
1330   (define-key clearcase-comment-mode-map "\C-x\C-s" 'clearcase-comment-save)
1331   (define-key clearcase-comment-mode-map "\C-x\C-q" 'clearcase-comment-num-num-error))
1332
1333 ;; Constants.
1334 ;;
1335 (defconst clearcase-comment-maximum-ring-size 32
1336   "Maximum number of saved comments in the comment ring.")
1337
1338 ;; Variables.
1339 ;;
1340 (defvar clearcase-comment-entry-mode nil)
1341 (defvar clearcase-comment-operation nil)
1342 (defvar clearcase-comment-operands)
1343 (defvar clearcase-comment-ring nil)
1344 (defvar clearcase-comment-ring-index nil)
1345 (defvar clearcase-comment-last-match nil)
1346 (defvar clearcase-comment-window-config nil)
1347
1348 ;; In several contexts, this is a local variable that points to the buffer for
1349 ;; which it was made (either a file, or a ClearCase dired buffer).
1350 ;;
1351 (defvar clearcase-parent-buffer nil)
1352 (defvar clearcase-parent-buffer-name nil)
1353
1354 ;;{{{ Commands and functions
1355
1356 (defun clearcase-comment-start-entry (uniquifier
1357                                       prompt
1358                                       continuation
1359                                       operands
1360                                       &optional parent-buffer comment-seed)
1361
1362   "Accept a comment by popping up a clearcase-comment-mode buffer
1363 with a name derived from UNIQUIFIER, and emitting PROMPT in the minibuffer.
1364 Set the continuation on close to CONTINUATION, which should be apply-ed to a list
1365 formed by appending OPERANDS and the comment-string.
1366
1367 Optional 5th argument specifies a PARENT-BUFFER to return to when the operation
1368 is complete.
1369
1370 Optional 6th argument specifies a COMMENT-SEED to insert in the comment buffer for
1371 the user to edit."
1372
1373   (let ((comment-buffer (get-buffer-create (format "*clearcase-comment-%s*" uniquifier)))
1374         (old-window-config (current-window-configuration))
1375         (parent (or parent-buffer
1376                     (current-buffer))))
1377     (pop-to-buffer comment-buffer)
1378
1379     ;; Record in buffer-local variables information sufficient to restore
1380     ;; window context.
1381     ;;
1382     (set (make-local-variable 'clearcase-comment-window-config) old-window-config)
1383     (set (make-local-variable 'clearcase-parent-buffer) parent)
1384
1385     (clearcase-comment-mode)
1386     (setq clearcase-comment-operation continuation)
1387     (setq clearcase-comment-operands operands)
1388     (if comment-seed
1389         (insert comment-seed))
1390     (message "%s  Type C-c C-c when done." prompt)))
1391
1392
1393 (defun clearcase-comment-cleanup ()
1394   ;; Make sure it ends with newline
1395   ;;
1396   (goto-char (point-max))
1397   (if (not (bolp))
1398       (newline))
1399
1400   ;; Remove useless whitespace.
1401   ;;
1402   (goto-char (point-min))
1403   (while (re-search-forward "[ \t]+$" nil t)
1404     (replace-match ""))
1405
1406   ;; Remove trailing newlines, whitespace.
1407   ;;
1408   (goto-char (point-max))
1409   (skip-chars-backward " \n\t")
1410   (delete-region (point) (point-max)))
1411
1412 (defun clearcase-comment-finish ()
1413   "Complete the operation implied by the current comment."
1414   (interactive)
1415
1416   ;;Clean and record the comment in the ring.
1417   ;;
1418   (let ((comment-buffer (current-buffer)))
1419     (clearcase-comment-cleanup)
1420
1421     (if (null clearcase-comment-ring)
1422         (setq clearcase-comment-ring (make-ring clearcase-comment-maximum-ring-size)))
1423     (ring-insert clearcase-comment-ring (buffer-string))
1424
1425     ;; Perform the operation on the operands.
1426     ;;
1427     (if clearcase-comment-operation
1428         (save-excursion
1429           (apply clearcase-comment-operation
1430                  (append clearcase-comment-operands (list (buffer-string)))))
1431       (error "No comment operation is pending"))
1432
1433     ;; Return to "parent" buffer of this operation.
1434     ;; Remove comment window.
1435     ;;
1436     (let ((old-window-config clearcase-comment-window-config))
1437       (pop-to-buffer clearcase-parent-buffer)
1438       (delete-windows-on comment-buffer)
1439       (kill-buffer comment-buffer)
1440       (if old-window-config (set-window-configuration old-window-config)))))
1441
1442 (defun clearcase-comment-save-comment-for-buffer (comment buffer)
1443   (save-excursion
1444     (set-buffer buffer)
1445     (let ((file (buffer-file-name)))
1446       (if (clearcase-fprop-checked-out file)
1447           (progn
1448             (clearcase-ct-do-cleartool-command "chevent"
1449                                                file
1450                                                comment
1451                                                (list "-replace"))
1452             (clearcase-fprop-set-comment file comment))
1453         (error "Can't change comment of checked-in version with this interface")))))
1454
1455 (defun clearcase-comment-save ()
1456   "Save the currently entered comment"
1457   (interactive)
1458   (let ((comment-string (buffer-string))
1459         (parent-buffer clearcase-parent-buffer))
1460     (if (not (buffer-modified-p))
1461         (message "(No changes need to be saved)")
1462       (progn
1463         (save-excursion
1464           (set-buffer parent-buffer)
1465           (clearcase-comment-save-comment-for-buffer comment-string parent-buffer))
1466
1467         (set-buffer-modified-p nil)))))
1468
1469 (defun clearcase-comment-num-num-error ()
1470   (interactive)
1471   (message "Perhaps you wanted to type C-c C-c instead?"))
1472
1473 ;; Code for the comment ring.
1474 ;;
1475 (defun clearcase-comment-next (arg)
1476   "Cycle forwards through comment history."
1477   (interactive "*p")
1478   (clearcase-comment-previous (- arg)))
1479
1480 (defun clearcase-comment-previous (arg)
1481   "Cycle backwards through comment history."
1482   (interactive "*p")
1483   (let ((len (ring-length clearcase-comment-ring)))
1484     (cond ((or (not len) (<= len 0))
1485            (message "Empty comment ring")
1486            (ding))
1487           (t
1488            (erase-buffer)
1489
1490            ;; Initialize the index on the first use of this command so that the
1491            ;; first M-p gets index 0, and the first M-n gets index -1.
1492            ;;
1493            (if (null clearcase-comment-ring-index)
1494                (setq clearcase-comment-ring-index
1495                      (if (> arg 0) -1
1496                        (if (< arg 0) 1 0))))
1497            (setq clearcase-comment-ring-index
1498                  (mod (+ clearcase-comment-ring-index arg) len))
1499            (message "%d" (1+ clearcase-comment-ring-index))
1500            (insert (ring-ref clearcase-comment-ring clearcase-comment-ring-index))))))
1501
1502 (defun clearcase-comment-search-forward (str)
1503   "Searches forwards through comment history for substring match."
1504   (interactive "sComment substring: ")
1505   (if (string= str "")
1506       (setq str clearcase-comment-last-match)
1507     (setq clearcase-comment-last-match str))
1508   (if (null clearcase-comment-ring-index)
1509       (setq clearcase-comment-ring-index 0))
1510   (let ((str (regexp-quote str))
1511         (n clearcase-comment-ring-index))
1512     (while (and (>= n 0) (not (string-match str (ring-ref clearcase-comment-ring n))))
1513       (setq n (- n 1)))
1514     (cond ((>= n 0)
1515            (clearcase-comment-next (- n clearcase-comment-ring-index)))
1516           (t (error "Not found")))))
1517
1518 (defun clearcase-comment-search-reverse (str)
1519   "Searches backwards through comment history for substring match."
1520   (interactive "sComment substring: ")
1521   (if (string= str "")
1522       (setq str clearcase-comment-last-match)
1523     (setq clearcase-comment-last-match str))
1524   (if (null clearcase-comment-ring-index)
1525       (setq clearcase-comment-ring-index -1))
1526   (let ((str (regexp-quote str))
1527         (len (ring-length clearcase-comment-ring))
1528         (n (1+ clearcase-comment-ring-index)))
1529     (while (and (< n len)
1530                 (not (string-match str (ring-ref clearcase-comment-ring n))))
1531       (setq n (+ n 1)))
1532     (cond ((< n len)
1533            (clearcase-comment-previous (- n clearcase-comment-ring-index)))
1534           (t (error "Not found")))))
1535
1536 ;;}}}
1537
1538 ;;}}}
1539
1540 ;;{{{ Major Mode: for editing config-specs.
1541
1542 ;; The major mode function.
1543 ;;
1544 (defun clearcase-edcs-mode ()
1545   (interactive)
1546   (set-syntax-table text-mode-syntax-table)
1547   (use-local-map clearcase-edcs-mode-map)
1548   (setq major-mode 'clearcase-edcs-mode)
1549   (setq mode-name "ClearCase/edcs")
1550   (make-variable-buffer-local 'clearcase-parent-buffer)
1551   (set-buffer-modified-p nil)
1552   (setq buffer-file-name nil)
1553   (run-hooks 'text-mode-hook 'clearcase-edcs-mode-hook))
1554
1555 ;; The keymap.
1556 ;;
1557 (defvar clearcase-edcs-mode-map nil)
1558 (if clearcase-edcs-mode-map
1559     nil
1560   (setq clearcase-edcs-mode-map (make-sparse-keymap))
1561   (define-key clearcase-edcs-mode-map "\C-c\C-c" 'clearcase-edcs-finish)
1562   (define-key clearcase-edcs-mode-map "\C-x\C-s" 'clearcase-edcs-save))
1563
1564 ;; Variables.
1565 ;;
1566 (defvar clearcase-edcs-tag-name nil
1567   "Name of view tag which is currently being edited")
1568
1569 (defvar clearcase-edcs-tag-history ()
1570   "History of view tags used in clearcase-edcs-edit")
1571
1572 ;;{{{ Commands
1573
1574 (defun clearcase-edcs-edit (tag-name)
1575   "Edit a ClearCase configuration specification"
1576
1577   (interactive
1578    (let ((vxname (clearcase-fprop-viewtag default-directory)))
1579      (if clearcase-complete-viewtags
1580          (list (directory-file-name
1581                 (completing-read "View Tag: "
1582                                  (clearcase-viewtag-all-viewtags-obarray)
1583                                  nil
1584                                  ;;'fascist
1585                                  nil
1586                                  vxname
1587                                  'clearcase-edcs-tag-history)))
1588        (read-string "View Tag: "))))
1589
1590   (let ((start (current-buffer))
1591         (buffer-name (format "*clearcase-config-spec-%s*" tag-name)))
1592     (kill-buffer (get-buffer-create buffer-name))
1593     (pop-to-buffer (get-buffer-create buffer-name))
1594     (auto-save-mode auto-save-default)
1595     (erase-buffer)
1596     (insert (clearcase-ct-cleartool-cmd "catcs" "-tag" tag-name))
1597     (goto-char (point-min))
1598     (re-search-forward "^[^#\n]" nil 'end)
1599     (beginning-of-line)
1600     (clearcase-edcs-mode)
1601     (setq clearcase-parent-buffer start)
1602     (make-local-variable 'clearcase-edcs-tag-name)
1603     (setq clearcase-edcs-tag-name tag-name)))
1604
1605 (defun clearcase-edcs-save ()
1606   (interactive)
1607   (if (not (buffer-modified-p))
1608       (message "Configuration not changed since last saved")
1609
1610     (message "Setting configuration for %s..." clearcase-edcs-tag-name)
1611     (clearcase-with-tempfile
1612      cspec-text
1613      (write-region (point-min) (point-max) cspec-text nil 'dont-mention-it)
1614      (let ((ret (clearcase-ct-cleartool-cmd "setcs"
1615                                             "-tag"
1616                                             clearcase-edcs-tag-name
1617                                             (clearcase-path-native cspec-text))))
1618
1619        ;; nyi: we could be smarter and retain viewtag info and perhaps some
1620        ;;      other info. For now invalidate all cached file property info.
1621        ;;
1622        (clearcase-fprop-clear-all-properties)
1623
1624        (set-buffer-modified-p nil)
1625        (message "Setting configuration for %s...done"
1626                 clearcase-edcs-tag-name)))))
1627
1628 (defun clearcase-edcs-finish ()
1629   (interactive)
1630   (let ((old-buffer (current-buffer)))
1631     (clearcase-edcs-save)
1632     (bury-buffer nil)
1633     (kill-buffer old-buffer)))
1634
1635 ;;}}}
1636
1637 ;;}}}
1638
1639 ;;{{{ View browser
1640
1641 ;; nyi: Just an idea now.
1642 ;;      Be able to present a selection of views at various times
1643 ;;        - show me current file in other view
1644 ;;        - top-level browse operation
1645
1646 ;;  clearcase-viewtag-started-viewtags gives us the dynamic views that are mounted.
1647
1648 ;;  How to find local snapshots ?
1649
1650 ;; How to find drive-letter mount points for view on NT ?
1651 ;;  - parse "subst" output
1652
1653 ;;}}}
1654
1655 ;;{{{ Commands
1656
1657 ;;{{{ Hijack/unhijack
1658
1659 (defun clearcase-hijack-current-buffer ()
1660   "Hijack the file in the current buffer."
1661   (interactive)
1662   (clearcase-hijack buffer-file-name))
1663
1664 (defun clearcase-hijack-dired-files ()
1665   "Hijack the selected files."
1666   (interactive)
1667   (clearcase-hijack-seq (dired-get-marked-files)))
1668
1669 (defun clearcase-unhijack-current-buffer ()
1670   "Unhijack the file in the current buffer."
1671   (interactive)
1672   (clearcase-unhijack buffer-file-name))
1673
1674 (defun clearcase-unhijack-dired-files ()
1675   "Hijack the selected files."
1676   (interactive)
1677   (clearcase-unhijack-seq (dired-get-marked-files)))
1678
1679 ;;}}}
1680
1681 ;;{{{ Annotate
1682
1683 (defun clearcase-annotate-file (file)
1684   (let ((relative-name (file-relative-name file)))
1685     (message "Annotating %s ..." relative-name)
1686     (clearcase-with-tempfile
1687      annotation-file
1688      (clearcase-ct-do-cleartool-command "annotate"
1689                                         file
1690                                         'unused
1691                                         (list "-nco"
1692                                               "-out"
1693                                               annotation-file))
1694      (clearcase-utl-populate-and-view-buffer
1695       "*clearcase-annotate*"
1696       nil
1697       (function
1698        (lambda ()
1699          (insert-file-contents annotation-file)))))
1700     (message "Annotating %s ...done" relative-name)))
1701
1702 (defun clearcase-annotate-current-buffer ()
1703   (interactive)
1704   (clearcase-annotate-file buffer-file-name))
1705
1706 (defun clearcase-annotate-dired-file ()
1707   "Annotate the selected file."
1708   (interactive)
1709   (clearcase-annotate-file (dired-get-filename)))
1710
1711 ;;}}}
1712
1713 ;;{{{ nyi: Find checkouts
1714
1715 ;; NYI: Enhance this:
1716 ;;  - group by:
1717 ;;    - activity name
1718 ;;    - checkout comment
1719 ;;  - permit unco/checkin
1720 ;;
1721 (defun clearcase-find-checkouts-in-current-view ()
1722   "Find the checkouts in all vobs in the current view."
1723   (interactive)
1724   (let ((viewtag (clearcase-fprop-viewtag default-directory))
1725         (dir default-directory))
1726     (if viewtag
1727         (let* ((ignore (message "Finding checkouts..."))
1728                (text (clearcase-ct-blocking-call "lsco"
1729                                                  "-cview"
1730                                                  "-avobs"
1731                                                  "-short")))
1732           (if (zerop (length text))
1733               (message "No checkouts found")
1734             (progn
1735               (message "Finding checkouts...done")
1736
1737               (clearcase-utl-populate-and-view-buffer
1738                "*clearcase*"
1739                (list text)
1740                (function (lambda (s)
1741                            (insert s))))))))))
1742
1743 ;;}}}
1744
1745 ;;{{{ UCM operations
1746
1747 ;;{{{ Make activity
1748
1749 (defun clearcase-read-new-activity-name ()
1750   "Read the name of a new activity from the minibuffer.
1751 Return nil if the empty string is entered."
1752
1753   ;; nyi: Probably should check that the activity doesn't already exist.
1754   ;;
1755   (let ((entered-name (read-string "Activity name (optional): " )))
1756     (if (not (zerop (length entered-name)))
1757         entered-name
1758       nil)))
1759
1760 (defun clearcase-read-mkact-args ()
1761   "Read the name and headline arguments for clearcase-ucm-mkact-current-dir
1762 from the minibuffer."
1763
1764   (let ((name nil)
1765         (headline ""))
1766     (if clearcase-prompt-for-activity-names
1767         (setq name (clearcase-read-new-activity-name)))
1768     (setq headline (read-string "Activity headline: " ))
1769     (list name headline)))
1770
1771 (defun clearcase-make-internally-named-activity (stream-name comment-file)
1772   "Make a new activity in STREAM-NAME with creation comment in COMMENT-FILE,
1773 and use an internally-generated name for the activity."
1774
1775   (let ((ret
1776          (if clearcase-set-to-new-activity
1777              (clearcase-ct-blocking-call "mkact"
1778                                          "-cfile" (clearcase-path-native comment-file)
1779                                          "-in" stream-name
1780                                          "-force")
1781            (clearcase-ct-blocking-call "mkact"
1782                                        "-nset"
1783                                        "-cfile" (clearcase-path-native comment-file)
1784                                        "-in" stream-name
1785                                        "-nset"
1786                                        "-force"))))
1787     (if (string-match "Created activity \"\\([^\"]+\\)\"" ret)
1788         (substring ret (match-beginning 1) (match-end 1))
1789       (error "Failed to create activity: %s" ret))))
1790
1791 (defun clearcase-ucm-mkact-current-dir (name headline &optional comment)
1792
1793   "Make an activity with NAME and HEADLINE and optional COMMENT, in the stream
1794 associated with the view associated with the current directory."
1795
1796   (interactive (clearcase-read-mkact-args))
1797   (let* ((viewtag (clearcase-fprop-viewtag default-directory))
1798          (stream  (clearcase-vprop-stream viewtag))
1799          (pvob    (clearcase-vprop-pvob viewtag)))
1800     (if (not (clearcase-vprop-ucm viewtag))
1801         (error "View %s is not a UCM view" viewtag))
1802     (if (null stream)
1803         (error "View %s has no stream" viewtag))
1804     (if (null stream)
1805         (error "View %s has no PVOB" viewtag))
1806
1807     (if (null comment)
1808         ;; If no comment supplied, go and get one..
1809         ;;
1810         (progn
1811           (clearcase-comment-start-entry (format "new-activity-%d" (random))
1812                                          "Enter comment for new activity."
1813                                          'clearcase-ucm-mkact-current-dir
1814                                          (list name headline)))
1815       ;; ...else do the operation.
1816       ;;
1817       (message "Making activity...")
1818       (clearcase-with-tempfile
1819        comment-file
1820        (write-region comment nil comment-file nil 'noprint)
1821        (let ((qualified-stream (format "%s@%s" stream pvob)))
1822          (if (stringp name)
1823              (if clearcase-set-to-new-activity
1824                  (clearcase-ct-blocking-call "mkact"
1825                                              "-cfile" (clearcase-path-native comment-file)
1826                                              "-headline" headline
1827                                              "-in" qualified-stream
1828                                              "-force"
1829                                              name)
1830                (clearcase-ct-blocking-call "mkact"
1831                                            "-nset"
1832                                            "-cfile" (clearcase-path-native comment-file)
1833                                            "-headline" headline
1834                                            "-in" qualified-stream
1835                                            "-force"
1836                                            name))
1837            (progn
1838              ;; If no name was provided we do the creation in two steps:
1839              ;;   mkact -force
1840              ;;   chact -headline
1841              ;; to make sure we get preferred internally generated activity
1842              ;; name of the form "activityNNN.MMM" rather than some horrible
1843              ;; concoction based on the headline.
1844              ;;
1845              (let ((name (clearcase-make-internally-named-activity qualified-stream comment-file)))
1846                (clearcase-ct-blocking-call "chact"
1847                                            "-headline" headline
1848                                            name))))))
1849
1850       ;; Flush the activities for this view so they'll get refreshed when needed.
1851       ;;
1852       (clearcase-vprop-flush-activities viewtag)
1853
1854       (message "Making activity...done"))))
1855
1856 ;;}}}
1857
1858 ;;{{{ Set activity
1859
1860 (defun clearcase-ucm-filter-out-rebases (activities)
1861   (if (not clearcase-hide-rebase-activities)
1862       activities
1863     (clearcase-utl-list-filter
1864      (function
1865       (lambda (activity)
1866         (let ((id (car activity)))
1867           (not (string-match clearcase-rebase-id-regexp id)))))
1868      activities)))
1869
1870 (defun clearcase-ucm-set-activity-current-dir ()
1871   (interactive)
1872   (let* ((viewtag (clearcase-fprop-viewtag default-directory)))
1873     (if (not (clearcase-vprop-ucm viewtag))
1874         (error "View %s is not a UCM view" viewtag))
1875     ;; Filter out the rebases here if the user doesn't want to see them.
1876     ;;
1877     (let ((activities (clearcase-ucm-filter-out-rebases (clearcase-vprop-activities viewtag))))
1878       (if (null activities)
1879           (error "View %s has no activities" viewtag))
1880       (clearcase-ucm-make-selection-window (format "*clearcase-activity-select-%s*" viewtag)
1881                                            (mapconcat
1882                                             (function
1883                                              (lambda (activity)
1884                                                (let ((id (car activity))
1885                                                      (title (cdr activity)))
1886                                                  (format "%s\t%s" id title))))
1887                                             activities
1888                                             "\n")
1889                                            'clearcase-ucm-activity-selection-interpreter
1890                                            'clearcase-ucm-set-activity
1891                                            (list viewtag)))))
1892
1893 (defun clearcase-ucm-activity-selection-interpreter ()
1894   "Extract the activity name from the buffer at point"
1895   (if (looking-at "^\\(.*\\)\t")
1896       (let ((activity-name (buffer-substring (match-beginning 1)
1897                                              (match-end 1))))
1898         activity-name)
1899     (error "No activity on this line")))
1900
1901 (defun clearcase-ucm-set-activity-none-current-dir ()
1902   (interactive)
1903   (let* ((viewtag (clearcase-fprop-viewtag default-directory)))
1904     (if (not (clearcase-vprop-ucm viewtag))
1905         (error "View %s is not a UCM view" viewtag))
1906     (clearcase-ucm-set-activity viewtag nil)))
1907
1908 (defun clearcase-ucm-set-activity (viewtag activity-name)
1909   (if activity-name
1910       ;; Set an activity
1911       ;;
1912       (progn
1913         (message "Setting activity...")
1914         (let ((qualified-activity-name (if (string-match "@" activity-name)
1915                                            activity-name
1916                                          (concat activity-name "@" (clearcase-vprop-pvob viewtag)))))
1917           (clearcase-ct-blocking-call "setactivity" "-nc" "-view"
1918                                       viewtag
1919                                       (if qualified-activity-name
1920                                           qualified-activity-name
1921                                         "-none")))
1922         ;; Update cache
1923         ;;
1924         (clearcase-vprop-set-current-activity viewtag activity-name)
1925         (message "Setting activity...done"))
1926
1927     ;; Set NO activity
1928     ;;
1929     (message "Unsetting activity...")
1930     (clearcase-ct-blocking-call "setactivity"
1931                                 "-nc"
1932                                 "-view" viewtag
1933                                 "-none")
1934     ;; Update cache
1935     ;;
1936     (clearcase-vprop-set-current-activity viewtag nil)
1937     (message "Unsetting activity...done")))
1938
1939 ;;}}}
1940
1941 ;;{{{ Show current activity
1942
1943 (defun clearcase-ucm-describe-current-activity ()
1944   (interactive)
1945   (let* ((viewtag (clearcase-fprop-viewtag default-directory)))
1946     (if (not viewtag)
1947         (error "Not in a view"))
1948     (if (not (clearcase-vprop-ucm viewtag))
1949         (error "View %s is not a UCM view" viewtag))
1950     (let ((pvob (clearcase-vprop-pvob viewtag))
1951           (current-activity (clearcase-vprop-current-activity viewtag)))
1952       (if (not current-activity)
1953           (message "No activity set")
1954         (let ((text (clearcase-ct-blocking-call "desc"
1955                                                 (concat "activity:"
1956                                                         current-activity
1957                                                         "@"
1958                                                         pvob))))
1959           (if (not (zerop (length text)))
1960               (clearcase-utl-populate-and-view-buffer
1961                "*clearcase*"
1962                (list text)
1963                (function (lambda (s)
1964                            (insert s))))))))))
1965 ;;}}}
1966
1967 ;;}}}
1968
1969 ;;{{{ Next-action
1970
1971 (defun clearcase-next-action-current-buffer ()
1972   "Do the next logical operation on the current file.
1973 Operations include mkelem, checkout, checkin, uncheckout"
1974   (interactive)
1975   (clearcase-next-action buffer-file-name))
1976
1977 (defun clearcase-next-action-dired-files ()
1978   "Do the next logical operation on the marked files.
1979 Operations include mkelem, checkout, checkin, uncheckout.
1980 If all the files are not in an equivalent state, an error is raised."
1981
1982   (interactive)
1983   (clearcase-next-action-seq (dired-get-marked-files)))
1984
1985 (defun clearcase-next-action (file)
1986   (let ((action (clearcase-compute-next-action file)))
1987     (cond
1988
1989      ((eq action 'mkelem)
1990       (clearcase-commented-mkelem file))
1991
1992      ((eq action 'checkout)
1993       (clearcase-commented-checkout file))
1994
1995      ((eq action 'uncheckout)
1996       (if (yes-or-no-p "Checked-out file appears unchanged. Cancel checkout ? ")
1997           (clearcase-uncheckout file)))
1998
1999      ((eq action 'illegal-checkin)
2000       (error "This file is checked out by someone else: %s" (clearcase-fprop-user file)))
2001
2002      ((eq action 'checkin)
2003       (clearcase-commented-checkin file))
2004
2005      (t
2006       (error "Can't compute suitable next ClearCase action for file %s" file)))))
2007
2008 (defun clearcase-next-action-seq (files)
2009   "Do the next logical operation on the sequence of FILES."
2010
2011   ;; Check they're all in the same state.
2012   ;;
2013   (let ((actions (mapcar (function clearcase-compute-next-action) files)))
2014     (if (not (clearcase-utl-elts-are-eq actions))
2015         (error "Marked files are not all in the same state"))
2016     (let ((action (car actions)))
2017       (cond
2018
2019        ((eq action 'mkelem)
2020         (clearcase-commented-mkelem-seq files))
2021
2022        ((eq action 'checkout)
2023         (clearcase-commented-checkout-seq files))
2024
2025        ((eq action 'uncheckout)
2026         (if (yes-or-no-p "Checked-out files appears unchanged. Cancel checkouts ? ")
2027             (clearcase-uncheckout-seq files)))
2028
2029        ((eq action 'illegal-checkin)
2030         (error "These files are checked out by someone else; will no checkin"))
2031
2032        ((eq action 'checkin)
2033         (clearcase-commented-checkin-seq files))
2034
2035        (t
2036         (error "Can't compute suitable next ClearCase action for marked files"))))))
2037
2038 (defun clearcase-compute-next-action (file)
2039   "Compute the next logical action on FILE."
2040
2041   (cond
2042    ;; nyi: other cases to consider later:
2043    ;;
2044    ;;   - file is unreserved
2045    ;;   - file is not mastered
2046
2047    ;; Case 1: it is not yet an element
2048    ;;         ==> mkelem
2049    ;;
2050    ((clearcase-file-ok-to-mkelem file)
2051     'mkelem)
2052
2053    ;; Case 2: file is not checked out
2054    ;;         ==> checkout
2055    ;;
2056    ((clearcase-file-ok-to-checkout file)
2057     'checkout)
2058
2059    ;; Case 3: file is checked-out but not modified in buffer or disk
2060    ;;         ==> offer to uncheckout
2061    ;;
2062    ((and (clearcase-file-ok-to-uncheckout file)
2063          (not (file-directory-p file))
2064          (not (buffer-modified-p))
2065          (not (clearcase-file-appears-modified-since-checkout-p file)))
2066     'uncheckout)
2067
2068    ;; Case 4: file is checked-out but by somebody else using this view.
2069    ;;         ==> refuse to checkin
2070    ;;
2071    ;; This is not reliable on some Windows installations where a user is known
2072    ;; as "esler" on Unix and the ClearCase server, and "ESLER" on the Windows
2073    ;; client.
2074    ;;
2075    ((and (not clearcase-on-mswindows)
2076          (clearcase-fprop-checked-out file)
2077          (not (string= (user-login-name)
2078                        (clearcase-fprop-user file))))
2079     'illegal-checkin)
2080
2081    ;; Case 5: user has checked-out the file
2082    ;;         ==> check it in
2083    ;;
2084    ((clearcase-file-ok-to-checkin file)
2085     'checkin)
2086
2087    (t
2088     nil)))
2089
2090 ;;}}}
2091
2092 ;;{{{ Mkelem
2093
2094 (defun clearcase-mkelem-current-buffer ()
2095   "Make the current file into a ClearCase element."
2096   (interactive)
2097
2098   ;; Watch out for new buffers of size 0: the corresponding file
2099   ;; does not exist yet, even though buffer-modified-p is nil.
2100   ;;
2101   (if (and (not (buffer-modified-p))
2102            (zerop (buffer-size))
2103            (not (file-exists-p buffer-file-name)))
2104       (set-buffer-modified-p t))
2105
2106   (clearcase-commented-mkelem buffer-file-name))
2107
2108 (defun clearcase-mkelem-dired-files ()
2109   "Make the selected files into ClearCase elements."
2110   (interactive)
2111   (clearcase-commented-mkelem-seq (dired-get-marked-files)))
2112
2113 ;;}}}
2114
2115 ;;{{{ Checkin
2116
2117 (defun clearcase-checkin-current-buffer ()
2118   "Checkin the file in the current buffer."
2119   (interactive)
2120
2121   ;; Watch out for new buffers of size 0: the corresponding file
2122   ;; does not exist yet, even though buffer-modified-p is nil.
2123   ;;
2124   (if (and (not (buffer-modified-p))
2125            (zerop (buffer-size))
2126            (not (file-exists-p buffer-file-name)))
2127       (set-buffer-modified-p t))
2128
2129   (clearcase-commented-checkin buffer-file-name))
2130
2131 (defun clearcase-checkin-dired-files ()
2132   "Checkin the selected files."
2133   (interactive)
2134   (clearcase-commented-checkin-seq (dired-get-marked-files)))
2135
2136 (defun clearcase-dired-checkin-current-dir ()
2137   (interactive)
2138   (clearcase-commented-checkin (dired-current-directory)))
2139
2140 ;;}}}
2141
2142 ;;{{{ Edit checkout comment
2143
2144 (defun clearcase-edit-checkout-comment-current-buffer ()
2145   "Edit the clearcase comment for the checked-out file in the current buffer."
2146   (interactive)
2147   (clearcase-edit-checkout-comment buffer-file-name))
2148
2149 (defun clearcase-edit-checkout-comment-dired-file ()
2150   "Checkin the selected file."
2151   (interactive)
2152   (clearcase-edit-checkout-comment (dired-get-filename)))
2153
2154 (defun clearcase-edit-checkout-comment (file &optional comment)
2155   "Edit comment for FILE by popping up a buffer to accept one.  If COMMENT
2156 is specified, save it."
2157   (if (null comment)
2158       ;; If no comment supplied, go and get one...
2159       ;;
2160       (clearcase-comment-start-entry (file-name-nondirectory file)
2161                                      "Edit the file's check-out comment."
2162                                      'clearcase-edit-checkout-comment
2163                                      (list buffer-file-name)
2164                                      (find-file-noselect file)
2165                                      (clearcase-fprop-comment file))
2166     ;; We have a comment, save it
2167     (clearcase-comment-save-comment-for-buffer comment clearcase-parent-buffer)))
2168
2169 ;;}}}
2170
2171 ;;{{{ Checkout
2172
2173 (defun clearcase-checkout-current-buffer ()
2174   "Checkout the file in the current buffer."
2175   (interactive)
2176   (clearcase-commented-checkout buffer-file-name))
2177
2178 (defun clearcase-checkout-dired-files ()
2179   "Checkout the selected files."
2180   (interactive)
2181   (clearcase-commented-checkout-seq (dired-get-marked-files)))
2182
2183 (defun clearcase-dired-checkout-current-dir ()
2184   (interactive)
2185   (clearcase-commented-checkout (dired-current-directory)))
2186
2187 ;;}}}
2188
2189 ;;{{{ Uncheckout
2190
2191 (defun clearcase-uncheckout-current-buffer ()
2192   "Uncheckout the file in the current buffer."
2193   (interactive)
2194   (clearcase-uncheckout buffer-file-name))
2195
2196 (defun clearcase-uncheckout-dired-files ()
2197   "Uncheckout the selected files."
2198   (interactive)
2199   (clearcase-uncheckout-seq (dired-get-marked-files)))
2200
2201 (defun clearcase-dired-uncheckout-current-dir ()
2202   (interactive)
2203   (clearcase-uncheckout (dired-current-directory)))
2204
2205 ;;}}}
2206
2207 ;;{{{ Mkbrtype
2208
2209 (defun clearcase-mkbrtype (typename)
2210   (interactive "sBranch type name: ")
2211   (clearcase-commented-mkbrtype typename))
2212
2213 ;;}}}
2214
2215 ;;{{{ Describe
2216
2217 (defun clearcase-describe-current-buffer ()
2218   "Give a ClearCase description of the file in the current buffer."
2219   (interactive)
2220   (clearcase-describe buffer-file-name))
2221
2222 (defun clearcase-describe-dired-file ()
2223   "Describe the selected files."
2224   (interactive)
2225   (clearcase-describe (dired-get-filename)))
2226
2227 ;;}}}
2228
2229 ;;{{{ What-rule
2230
2231 (defun clearcase-what-rule-current-buffer ()
2232   (interactive)
2233   (clearcase-what-rule buffer-file-name))
2234
2235 (defun clearcase-what-rule-dired-file ()
2236   (interactive)
2237   (clearcase-what-rule (dired-get-filename)))
2238
2239 ;;}}}
2240
2241 ;;{{{ List history
2242
2243 (defun clearcase-list-history-current-buffer ()
2244   "List the change history of the current buffer in a window."
2245   (interactive)
2246   (clearcase-list-history buffer-file-name))
2247
2248 (defun clearcase-list-history-dired-file ()
2249   "List the change history of the current file."
2250   (interactive)
2251   (clearcase-list-history (dired-get-filename)))
2252
2253 ;;}}}
2254
2255 ;;{{{ Ediff
2256
2257 (defun clearcase-ediff-pred-current-buffer ()
2258   "Use Ediff to compare a version in the current buffer against its predecessor."
2259   (interactive)
2260   (clearcase-ediff-file-with-version buffer-file-name
2261                                      (clearcase-fprop-predecessor-version buffer-file-name)))
2262
2263 (defun clearcase-ediff-pred-dired-file ()
2264   "Use Ediff to compare the selected version against its predecessor."
2265   (interactive)
2266   (let ((truename (clearcase-fprop-truename (dired-get-filename))))
2267     (clearcase-ediff-file-with-version truename
2268                                        (clearcase-fprop-predecessor-version truename))))
2269
2270 (defun clearcase-ediff-branch-base-current-buffer()
2271   "Use Ediff to compare a version in the current buffer
2272 against the base of its branch."
2273   (interactive)
2274   (clearcase-ediff-file-with-version buffer-file-name
2275                                      (clearcase-vxpath-version-of-branch-base buffer-file-name)))
2276
2277 (defun clearcase-ediff-branch-base-dired-file()
2278   "Use Ediff to compare the selected version against the base of its branch."
2279   (interactive)
2280   (let ((truename (clearcase-fprop-truename (dired-get-filename))))
2281     (clearcase-ediff-file-with-version truename
2282                                        (clearcase-vxpath-version-of-branch-base truename))))
2283
2284 (defun clearcase-ediff-named-version-current-buffer (version)
2285   ;; nyi: if we're in history-mode, probably should just use
2286   ;; (read-file-name)
2287   ;;
2288   (interactive (list (clearcase-read-version-name "Version for comparison: "
2289                                                   buffer-file-name)))
2290   (clearcase-ediff-file-with-version buffer-file-name version))
2291
2292 (defun clearcase-ediff-named-version-dired-file (version)
2293   ;; nyi: if we're in history-mode, probably should just use
2294   ;; (read-file-name)
2295   ;;
2296   (interactive (list (clearcase-read-version-name "Version for comparison: "
2297                                                   (dired-get-filename))))
2298   (clearcase-ediff-file-with-version  (clearcase-fprop-truename (dired-get-filename))
2299                                       version))
2300
2301 (defun clearcase-ediff-file-with-version (truename other-version)
2302   (let ((other-vxpath (clearcase-vxpath-cons-vxpath (clearcase-vxpath-element-part truename)
2303                                                     other-version)))
2304     (if (clearcase-file-is-in-mvfs-p truename)
2305         (ediff-files other-vxpath truename)
2306       (ediff-buffers (clearcase-vxpath-get-version-in-buffer other-vxpath)
2307                      (find-file-noselect truename t)))))
2308
2309 ;;}}}
2310
2311 ;;{{{ GUI diff
2312
2313 (defun clearcase-gui-diff-pred-current-buffer ()
2314   "Use GUI to compare a version in the current buffer against its predecessor."
2315   (interactive)
2316   (clearcase-gui-diff-file-with-version buffer-file-name
2317                                         (clearcase-fprop-predecessor-version buffer-file-name)))
2318
2319 (defun clearcase-gui-diff-pred-dired-file ()
2320   "Use GUI to compare the selected version against its predecessor."
2321   (interactive)
2322   (let ((truename (clearcase-fprop-truename (dired-get-filename))))
2323     (clearcase-gui-diff-file-with-version truename
2324                                           (clearcase-fprop-predecessor-version truename))))
2325
2326 (defun clearcase-gui-diff-branch-base-current-buffer()
2327   "Use GUI to compare a version in the current buffer
2328 against the base of its branch."
2329   (interactive)
2330   (clearcase-gui-diff-file-with-version buffer-file-name
2331                                         (clearcase-vxpath-version-of-branch-base buffer-file-name)))
2332
2333 (defun clearcase-gui-diff-branch-base-dired-file()
2334   "Use GUI to compare the selected version against the base of its branch."
2335   (interactive)
2336   (let ((truename (clearcase-fprop-truename (dired-get-filename))))
2337     (clearcase-gui-diff-file-with-version truename
2338                                           (clearcase-vxpath-version-of-branch-base truename))))
2339
2340 (defun clearcase-gui-diff-named-version-current-buffer (version)
2341   ;; nyi: if we're in history-mode, probably should just use
2342   ;; (read-file-name)
2343   ;;
2344   (interactive (list (clearcase-read-version-name "Version for comparison: "
2345                                                   buffer-file-name)))
2346   (clearcase-gui-diff-file-with-version buffer-file-name version))
2347
2348 (defun clearcase-gui-diff-named-version-dired-file (version)
2349   ;; nyi: if we're in history-mode, probably should just use
2350   ;; (read-file-name)
2351   ;;
2352   (interactive (list (clearcase-read-version-name "Version for comparison: "
2353                                                   (dired-get-filename))))
2354   (clearcase-gui-diff-file-with-version  (clearcase-fprop-truename (dired-get-filename))
2355                                          version))
2356
2357 (defun clearcase-gui-diff-file-with-version (truename other-version)
2358   (let* ((other-vxpath (clearcase-vxpath-cons-vxpath (clearcase-vxpath-element-part truename)
2359                                                      other-version))
2360          (other-file (if (clearcase-file-is-in-mvfs-p truename)
2361                          other-vxpath
2362                        (clearcase-vxpath-get-version-in-temp-file other-vxpath)))
2363          (gui-name (if clearcase-on-mswindows
2364                        "cleardiffmrg"
2365                      "xcleardiff")))
2366     (start-process "Diff"
2367                    nil
2368                    gui-name
2369                    (clearcase-path-native other-file)
2370                    (clearcase-path-native truename))))
2371
2372 ;;}}}
2373
2374 ;;{{{ Diff
2375
2376 (defun clearcase-diff-pred-current-buffer ()
2377   "Use Diff to compare a version in the current buffer against its predecessor."
2378   (interactive)
2379   (clearcase-diff-file-with-version buffer-file-name
2380                                     (clearcase-fprop-predecessor-version buffer-file-name)))
2381
2382 (defun clearcase-diff-pred-dired-file ()
2383   "Use Diff to compare the selected version against its predecessor."
2384   (interactive)
2385   (let ((truename (clearcase-fprop-truename (dired-get-filename))))
2386     (clearcase-diff-file-with-version truename
2387                                       (clearcase-fprop-predecessor-version truename))))
2388
2389 (defun clearcase-diff-branch-base-current-buffer()
2390   "Use Diff to compare a version in the current buffer
2391 against the base of its branch."
2392   (interactive)
2393   (clearcase-diff-file-with-version buffer-file-name
2394                                     (clearcase-vxpath-version-of-branch-base buffer-file-name)))
2395
2396 (defun clearcase-diff-branch-base-dired-file()
2397   "Use Diff to compare the selected version against the base of its branch."
2398   (interactive)
2399   (let ((truename (clearcase-fprop-truename (dired-get-filename))))
2400     (clearcase-diff-file-with-version truename
2401                                       (clearcase-vxpath-version-of-branch-base truename))))
2402
2403 (defun clearcase-diff-named-version-current-buffer (version)
2404   ;; nyi: if we're in history-mode, probably should just use
2405   ;; (read-file-name)
2406   ;;
2407   (interactive (list (clearcase-read-version-name "Version for comparison: "
2408                                                   buffer-file-name)))
2409   (clearcase-diff-file-with-version buffer-file-name version))
2410
2411 (defun clearcase-diff-named-version-dired-file (version)
2412   ;; nyi: if we're in history-mode, probably should just use
2413   ;; (read-file-name)
2414   ;;
2415   (interactive (list (clearcase-read-version-name "Version for comparison: "
2416                                                   (dired-get-filename))))
2417   (clearcase-diff-file-with-version (clearcase-fprop-truename (dired-get-filename))
2418                                     version))
2419
2420 (defun clearcase-diff-file-with-version (truename other-version)
2421   (let ((other-vxpath (clearcase-vxpath-cons-vxpath (clearcase-vxpath-element-part truename)
2422                                                     other-version)))
2423     (if (clearcase-file-is-in-mvfs-p truename)
2424         (clearcase-diff-files other-vxpath truename)
2425       (clearcase-diff-files (clearcase-vxpath-get-version-in-temp-file other-vxpath)
2426                             truename))))
2427
2428 ;;}}}
2429
2430 ;;{{{ Browse vtree
2431
2432 (defun clearcase-version-other-window (version)
2433   (interactive
2434    (list
2435     (clearcase-read-version-name (format "Version of %s to visit: "
2436       (file-name-nondirectory buffer-file-name))
2437                                  buffer-file-name)))
2438   (find-file-other-window (clearcase-vxpath-cons-vxpath
2439                            (clearcase-vxpath-element-part buffer-file-name)
2440                            version)))
2441
2442 (defun clearcase-browse-vtree-current-buffer ()
2443   (interactive)
2444   (clearcase-browse-vtree buffer-file-name))
2445
2446 (defun clearcase-browse-vtree-dired-file ()
2447   (interactive)
2448   (clearcase-browse-vtree (dired-get-filename)))
2449
2450 ;;}}}
2451
2452 ;;{{{ GUI vtree
2453
2454 (defun clearcase-gui-vtree-browser-current-buffer ()
2455   (interactive)
2456   (clearcase-gui-vtree-browser buffer-file-name))
2457
2458 (defun clearcase-gui-vtree-browser-dired-file ()
2459   (interactive)
2460   (clearcase-gui-vtree-browser (dired-get-filename)))
2461
2462 (defun clearcase-gui-vtree-browser (file)
2463   (let ((gui-name (if clearcase-on-mswindows
2464                       "clearvtree"
2465                     "xlsvtree")))
2466     (start-process-shell-command "Vtree_browser"
2467                                  nil
2468                                  gui-name
2469                                  (clearcase-path-native file))))
2470
2471 ;;}}}
2472
2473 ;;{{{ Other GUIs
2474
2475 (defun clearcase-gui-clearexplorer ()
2476   (interactive)
2477   (start-process-shell-command "ClearExplorer"
2478                                nil
2479                                "clearexplorer"
2480                                "."))
2481
2482 (defun clearcase-gui-rebase ()
2483   (interactive)
2484   (start-process-shell-command "Rebase"
2485                                nil
2486                                "clearmrgman"
2487                                (if clearcase-on-mswindows
2488                                    "/rebase"
2489                                  "-rebase")))
2490
2491 (defun clearcase-gui-deliver ()
2492   (interactive)
2493   (start-process-shell-command "Deliver"
2494                                nil
2495                                "clearmrgman"
2496                                (if clearcase-on-mswindows
2497                                    "/deliver"
2498                                  "-deliver")))
2499
2500 (defun clearcase-gui-merge-manager ()
2501   (interactive)
2502   (start-process-shell-command "Merge_manager"
2503                                nil
2504                                "clearmrgman"))
2505
2506 (defun clearcase-gui-project-explorer ()
2507   (interactive)
2508   (start-process-shell-command "Project_explorer"
2509                                nil
2510                                "clearprojexp"))
2511
2512 (defun clearcase-gui-snapshot-view-updater ()
2513   (interactive)
2514   (start-process-shell-command "View_updater"
2515                                nil
2516                                "clearviewupdate"))
2517
2518 ;;}}}
2519
2520 ;;{{{ Update snapshot
2521
2522 ;; In a file buffer:
2523 ;;  - update current-file
2524 ;;  - update directory
2525 ;; In dired:
2526 ;;  - update dir
2527 ;;  - update marked files
2528 ;;  - update file
2529
2530 ;; We allow several simultaneous updates, but only one per view.
2531
2532 (defun clearcase-update-view ()
2533   (interactive)
2534   (clearcase-update (clearcase-fprop-viewtag default-directory)))
2535
2536 (defun clearcase-update-default-directory ()
2537   (interactive)
2538   (clearcase-update (clearcase-fprop-viewtag default-directory)
2539                     default-directory))
2540
2541 (defun clearcase-update-current-buffer ()
2542   (interactive)
2543   (clearcase-update (clearcase-fprop-viewtag default-directory)
2544                     buffer-file-name))
2545
2546 (defun clearcase-update-dired-files ()
2547   (interactive)
2548   (apply (function clearcase-update)
2549          (cons (clearcase-fprop-viewtag default-directory)
2550                (dired-get-marked-files))))
2551
2552
2553 ;;}}}
2554
2555 ;;}}}
2556
2557 ;;{{{ Functions
2558
2559 ;;{{{ Basic ClearCase operations
2560
2561 ;;{{{ Update snapshot view
2562
2563 ;;{{{ Asynchronous post-processing of update
2564
2565 (defvar clearcase-post-update-timer nil)
2566 (defvar clearcase-post-update-work-queue nil)
2567
2568 (defun clearcase-post-update-schedule-work (buffer)
2569   (clearcase-trace "entering clearcase-post-update-schedule-work")
2570   ;; Add to the work queue.
2571   ;;
2572   (setq clearcase-post-update-work-queue (cons buffer
2573                                                clearcase-post-update-work-queue))
2574   ;; Create the timer if necessary.
2575   ;;
2576   (if (null clearcase-post-update-timer)
2577       (if clearcase-xemacs-p
2578           ;; Xemacs
2579           ;;
2580           (setq clearcase-post-update-timer
2581                 (run-with-idle-timer 2 t 'clearcase-post-update-timer-function))
2582         ;; FSF Emacs
2583         ;;
2584         (progn
2585           (setq clearcase-post-update-timer (timer-create))
2586           (timer-set-function clearcase-post-update-timer 'clearcase-post-update-timer-function)
2587           (timer-set-idle-time clearcase-post-update-timer 2)
2588           (timer-activate-when-idle clearcase-post-update-timer)))
2589     (clearcase-trace "clearcase-post-update-schedule-work: post-update timer found to be non-null")))
2590
2591
2592 (defun clearcase-post-update-timer-function ()
2593   (clearcase-trace "Entering clearcase-post-update-timer-function")
2594   ;; For (each update-process buffer in the work queue)
2595   ;;   if (its process has successfully terminated)
2596   ;;      do the post-processing for this update
2597   ;;      remove it from the work queue
2598   ;;
2599   (clearcase-trace (format "Queue before: %s" clearcase-post-update-work-queue))
2600   (setq clearcase-post-update-work-queue
2601
2602         (clearcase-utl-list-filter
2603          (function clearcase-post-update-check-process-buffer)
2604          clearcase-post-update-work-queue))
2605
2606   (clearcase-trace (format "Queue after: %s" clearcase-post-update-work-queue))
2607   ;; If the work queue is now empty cancel the timer.
2608   ;;
2609   (if (null clearcase-post-update-work-queue)
2610       (progn
2611         (cancel-timer clearcase-post-update-timer)
2612         (setq clearcase-post-update-timer nil))))
2613
2614 (defun clearcase-post-update-check-process-buffer (buffer)
2615   (clearcase-trace "Entering clearcase-post-update-check-process-buffer")
2616
2617   ;; return t for those buffers that should remain in the work queue
2618
2619   ;; if it has terminated successfully
2620   ;;   go sync buffers on the files that were updated
2621
2622   ;; We want to field errors here and when they occurm return nil to avoid a
2623   ;; loop
2624   ;;
2625   ;;(condition-case nil
2626
2627   ;; protected form
2628   (let ((proc (get-buffer-process buffer)))
2629     (if proc
2630         ;; Process still exists so keep this on the work queue.
2631         ;;
2632         (progn
2633           (clearcase-trace "Update process still exists")
2634           t)
2635
2636       ;; Process no longer there, cleaned up by comint code.
2637       ;;
2638
2639       ;; Sync any buffers that need it.
2640       ;;
2641       (clearcase-trace "Update process finished")
2642       (clearcase-sync-after-scopes-updated (with-current-buffer buffer
2643                                              ;; Evaluate buffer-local variable.
2644                                              ;;
2645                                              clearcase-update-buffer-scopes))
2646
2647       ;; Remove  from work queue
2648       ;;
2649       nil))
2650
2651   ;; Error occurred, make sure we return nil to remove the buffer from the
2652   ;; work queue, or a loop could develop.
2653   ;;
2654   ;;(error nil)
2655   )
2656
2657 (defun clearcase-sync-after-scopes-updated (scopes)
2658   (clearcase-trace "Entering clearcase-sync-after-scopes-updated")
2659
2660   ;; nyi: reduce scopes to minimal set of disjoint scopes
2661
2662   ;; Use dynamic binding here since we don't have lexical binding.
2663   ;;
2664   (let ((clearcase-dynbound-updated-scopes scopes))
2665
2666     ;; For all buffers...
2667     ;;
2668     (mapcar
2669      (function
2670       (lambda (buffer)
2671         (let ((visited-file (buffer-file-name buffer)))
2672           (if visited-file
2673               (if (clearcase-path-file-in-any-scopes visited-file
2674                                                      clearcase-dynbound-updated-scopes)
2675                   ;; This buffer visits a file within an updated scope.
2676                   ;; Sync it from disk if it needs it.
2677                   ;;
2678                   (clearcase-sync-from-disk-if-needed visited-file))
2679
2680             ;; Buffer is not visiting a file.  If it is a dired-mode buffer
2681             ;; under one of the scopes, revert it.
2682             ;;
2683             (with-current-buffer buffer
2684               (if (eq 'dired-mode major-mode)
2685                   (if (clearcase-path-file-in-any-scopes default-directory
2686                                                          clearcase-dynbound-updated-scopes)
2687                       (dired-revert nil t))))))))
2688      (buffer-list))))
2689
2690 ;;}}}
2691
2692 ;; Silence compiler complaints about free variable.
2693 ;;
2694 (defvar clearcase-update-buffer-viewtag nil)
2695
2696 (defun clearcase-update (viewtag &rest files)
2697   "Run a cleartool+update process in VIEWTAG
2698 if there isn't one already running in that view.
2699 Other arguments FILES indicate files to update"
2700
2701   ;; Check that there is no update process running in that view.
2702   ;;
2703   (if (apply (function clearcase-utl-or-func)
2704              (mapcar (function (lambda (proc)
2705                                  (if (not (eq 'exit (process-status proc)))
2706                                      (let ((buf (process-buffer proc)))
2707                                        (and buf
2708                                             (assq 'clearcase-update-buffer-viewtag
2709                                                   (buffer-local-variables buf))
2710                                             (save-excursion
2711                                               (set-buffer buf)
2712                                               (equal viewtag
2713                                                      clearcase-update-buffer-viewtag)))))))
2714                      (process-list)))
2715       (error "There is already an update running in view %s" viewtag))
2716
2717   ;; All clear so:
2718   ;;  - create a process in a buffer
2719   ;;  - rename the buffer to be of the form *clearcase-update*<N>
2720   ;;  - mark it as one of ours by setting clearcase-update-buffer-viewtag
2721   ;;
2722   (pop-to-buffer (apply (function make-comint)
2723                         (append (list "*clearcase-update-temp-name*"
2724                                       clearcase-cleartool-path
2725                                       nil
2726                                       "update")
2727                                 files))
2728                  t) ;; other window
2729   (rename-buffer "*clearcase-update*" t)
2730
2731   ;; Store in this buffer what view was being updated and what files.
2732   ;;
2733   (set (make-local-variable 'clearcase-update-buffer-viewtag) viewtag)
2734   (set (make-local-variable 'clearcase-update-buffer-scopes) files)
2735
2736   ;; nyi: schedule post-update buffer syncing
2737   (clearcase-post-update-schedule-work (current-buffer)))
2738
2739 ;;}}}
2740
2741 ;;{{{ Hijack
2742
2743 (defun clearcase-file-ok-to-hijack (file)
2744
2745   "Test if FILE is suitable for hijack."
2746
2747   (and
2748
2749    ;; If it is writeable already, no need to offer a hijack operation, even
2750    ;; though, according to ClearCase, it may not yet be hijacked.
2751    ;;
2752    ;;(not (file-writable-p file))
2753
2754    (not (clearcase-fprop-hijacked file))
2755    (clearcase-file-is-in-view-p file)
2756    (not (clearcase-file-is-in-mvfs-p file))
2757    (eq 'version (clearcase-fprop-mtype file))
2758    (not (clearcase-fprop-checked-out file))))
2759
2760 (defun clearcase-hijack-seq (files)
2761   (unwind-protect
2762       (progn
2763         (message "Hijacking...")
2764         (mapcar
2765          (function
2766           (lambda (file)
2767             (if (not (file-directory-p file))
2768                 (clearcase-hijack file))))
2769          files))
2770     ;; Unwind
2771     ;;
2772     (message "Hijacking...done")))
2773
2774 (defun clearcase-hijack (file)
2775
2776   ;; cases
2777   ;;  - buffer/files modtimes are equal
2778   ;;  - file more recent
2779   ;;    ==> revert
2780   ;;  - buffer more recent
2781   ;;    ==> make file writeable; save buffer ?
2782   ;;
2783   ;; Post-conditions:
2784   ;;   - file is hijacked wrt. CC
2785   ;;   - buffer is in sync with disk contents, modtime and writeability
2786   ;;     except if the user refused to save
2787   ;;
2788   (if (not (file-writable-p file))
2789       ;; Make it writeable.
2790       ;;
2791       (clearcase-utl-make-writeable file))
2792
2793   ;; Attempt to modify the modtime of the file on disk, otherwise ClearCase
2794   ;; won't actually deem it hijacked. This will silently fail if there is no
2795   ;; "touch" command command available.
2796   ;;
2797   (clearcase-utl-touch-file file)
2798
2799   ;; Sync up any buffers.
2800   ;;
2801   (clearcase-sync-from-disk file t))
2802
2803 ;;}}}
2804
2805 ;;{{{ Unhijack
2806
2807 (defun clearcase-file-ok-to-unhijack (file)
2808   "Test if FILE is suitable for unhijack."
2809   (clearcase-fprop-hijacked file))
2810
2811 (defun clearcase-unhijack (file)
2812   (clearcase-unhijack-seq (list file)))
2813
2814 (defun cleartool-unhijack-parse-for-kept-files (ret snapshot-view-root)
2815   ;; Look for occurrences of:
2816   ;; Loading "source\emacs\.emacs.el" (296690 bytes).
2817   ;; (renaming original hijacked object to ".emacs.el.keep.10").
2818   ;;
2819   (let ((start 0)
2820         (kept-files nil))
2821     (while (string-match
2822             "^Loading \"\\([^\"]+\\)\"[^\n]+\n(renaming original hijacked object to \"\\([^\"]+\\)\")\\.\n"
2823             ret
2824             start)
2825       (let* ((elt-path (substring ret (match-beginning 1) (match-end 1)))
2826              (abs-elt-path (concat (if snapshot-view-root
2827                                        snapshot-view-root
2828                                      "/")
2829                                    elt-path))
2830              (abs-elt-dir (file-name-directory abs-elt-path ))
2831              (kept-file-rel (concat abs-elt-dir
2832                                     (substring ret (match-beginning 2) (match-end 2))))
2833
2834              ;; This is necessary on Windows to get an absolute path, i.e. one
2835              ;; with a drive letter. Note: probably only correct if
2836              ;; unhijacking files in a single snapshot view, mounted on a
2837              ;; drive-letter.
2838              ;;
2839              (kept-file (expand-file-name kept-file-rel)))
2840         (setq kept-files (cons kept-file kept-files)))
2841       (setq start (match-end 0)))
2842     kept-files))
2843
2844 (defun clearcase-utl-files-in-same-view-p (files)
2845   (if (< (length files) 2)
2846       t
2847     (let ((v0 (clearcase-fprop-viewtag (nth 0 files)))
2848           (v1 (clearcase-fprop-viewtag (nth 1 files))))
2849       (if (or (not (stringp v0))
2850               (not (stringp v1))
2851               (not (string= v0 v1)))
2852           nil
2853         (clearcase-utl-files-in-same-view-p (cdr files))))))
2854
2855 (defun clearcase-unhijack-seq (files)
2856
2857   ;; Check: there are no directories involved.
2858   ;;
2859   (mapcar
2860    (function
2861     (lambda (file)
2862       (if (file-directory-p file)
2863           (error "Cannot unhijack a directory"))))
2864    files)
2865
2866   ;; Check: all files are in the same snapshot view.
2867   ;;
2868   ;; (Why ?  The output from ct+update only has view-root-relative paths
2869   ;; and we need to obtain absolute paths of renamed-aside hijacks if we are to
2870   ;; dired-relist them.)
2871   ;;
2872   ;; Alternative: partition the set, with each partition containing elements in
2873   ;; the same view.
2874   ;;
2875   (if (not (clearcase-utl-files-in-same-view-p files))
2876       (error "Can't unhijack files in different views in the same operation"))
2877
2878   ;; Run the scoped workspace update synchronously.
2879   ;;
2880   (unwind-protect
2881       (progn
2882         (message "Unhijacking...")
2883         (let* ((ret (apply (function clearcase-ct-blocking-call)
2884                            (append (list "update"
2885                                          (if clearcase-keep-unhijacks
2886                                              "-rename"
2887                                            "-overwrite")
2888                                          "-log" clearcase-sink-file-name)
2889                                    files)))
2890                (snapshot-view-root (clearcase-file-snapshot-root (car files)))
2891
2892                ;; Scan for renamed-aside files.
2893                ;;
2894                (kept-files (if clearcase-keep-unhijacks
2895                                (cleartool-unhijack-parse-for-kept-files ret
2896                                                                         snapshot-view-root)
2897                              nil)))
2898
2899           ;; Do post-update synchronisation.
2900           ;;
2901           (mapcar
2902            (function clearcase-sync-after-file-updated-from-vob)
2903            files)
2904
2905           ;; Update any dired buffers as to the existence of the kept files.
2906           ;;
2907           (if clearcase-keep-unhijacks
2908               (mapcar (function
2909                        (lambda (file)
2910                          (dired-relist-file file)))
2911                       kept-files))))
2912     ;; unwind
2913     ;;
2914     (message "Unhijacking...done")))
2915
2916 ;;}}}
2917
2918 ;;{{{ Mkelem
2919
2920 (defun clearcase-file-ok-to-mkelem (file)
2921   "Test if FILE is okay to mkelem."
2922   (let ((mtype (clearcase-fprop-mtype file)))
2923     (and (not (file-directory-p file))
2924          (and (or (equal 'view-private-object mtype)
2925                   (equal 'derived-object mtype))
2926               (not (clearcase-fprop-hijacked file))
2927               (not (clearcase-file-covers-element-p file))))))
2928
2929 (defun clearcase-assert-file-ok-to-mkelem (file)
2930   "Raise an exception if FILE is not suitable for mkelem."
2931   (if (not (clearcase-file-ok-to-mkelem file))
2932       (error "%s cannot be made into an element" file)))
2933
2934 (defun clearcase-commented-mkelem (file &optional okay-to-checkout-dir-first comment)
2935   "Create a new element from FILE. If OKAY-TO-CHECKOUT-DIR-FIRST is non-nil,
2936 the containing directory will be checked out if necessary.
2937 If COMMENT is non-nil, it will be used, otherwise the user will be prompted
2938 to enter one."
2939
2940   ;; Pre-condition
2941   ;;
2942   (clearcase-assert-file-ok-to-mkelem file)
2943
2944   (let ((containing-dir (file-name-directory file)))
2945
2946     ;; Pre-condition
2947     ;;
2948     (if (not (eq 'directory-version (clearcase-fprop-mtype containing-dir)))
2949         (error "Parent directory of %s is not a ClearCase versioned directory."
2950                file))
2951
2952     ;; Determine if we'll need to checkout the parent directory first.
2953     ;;
2954     (let ((dir-checkout-needed (not (clearcase-fprop-checked-out containing-dir))))
2955       (if dir-checkout-needed
2956           (progn
2957             ;; Parent dir will need to be checked out. Get permission if
2958             ;; appropriate.
2959             ;;
2960             (if (null okay-to-checkout-dir-first)
2961                 (setq okay-to-checkout-dir-first
2962                       (or (null clearcase-verify-pre-mkelem-dir-checkout)
2963                           (y-or-n-p (format "Checkout directory %s " containing-dir)))))
2964             (if (null okay-to-checkout-dir-first)
2965                 (error "Can't make an element unless directory is checked-out."))))
2966
2967       (if (null comment)
2968           ;; If no comment supplied, go and get one...
2969           ;;
2970           (clearcase-comment-start-entry (file-name-nondirectory file)
2971                                          "Enter initial comment for the new element."
2972                                          'clearcase-commented-mkelem
2973                                          (list file okay-to-checkout-dir-first)
2974                                          (find-file-noselect file)
2975                                          clearcase-initial-mkelem-comment)
2976
2977         ;; ...otherwise perform the operation.
2978         ;;
2979
2980         ;;    We may need to checkout the directory.
2981         ;;
2982         (if dir-checkout-needed
2983             (clearcase-commented-checkout containing-dir comment))
2984
2985         (clearcase-fprop-unstore-properties file)
2986
2987         (message "Making element %s..." file)
2988
2989         (save-excursion
2990           ;; Sync the buffer to disk.
2991           ;;
2992           (let ((buffer-on-file (find-buffer-visiting file)))
2993             (if buffer-on-file
2994                 (progn
2995                   (set-buffer buffer-on-file)
2996                   (clearcase-sync-to-disk))))
2997
2998           (clearcase-ct-do-cleartool-command "mkelem"
2999                                              file
3000                                              comment
3001                                              (if clearcase-checkin-on-mkelem
3002                                                  (list "-ci")))
3003           (message "Making element %s...done" file)
3004
3005           ;; Resync.
3006           ;;
3007           (clearcase-sync-from-disk file t))))))
3008
3009 (defun clearcase-commented-mkelem-seq (files &optional comment)
3010   "Mkelem a sequence of FILES. If COMMENT is supplied it will be
3011 used, otherwise the user will be prompted to enter one."
3012
3013   (mapcar
3014    (function clearcase-assert-file-ok-to-mkelem)
3015    files)
3016
3017   (if (null comment)
3018       ;; No comment supplied, go and get one...
3019       ;;
3020       (clearcase-comment-start-entry "mkelem"
3021                                      "Enter comment for elements' creation"
3022                                      'clearcase-commented-mkelem-seq
3023                                      (list files))
3024     ;; ...otherwise operate.
3025     ;;
3026     (mapcar
3027      (function
3028       (lambda (file)
3029         (clearcase-commented-mkelem file nil comment)))
3030      files)))
3031
3032 ;;}}}
3033
3034 ;;{{{ Checkin
3035
3036 (defun clearcase-file-ok-to-checkin (file)
3037   "Test if FILE is suitable for checkin."
3038   (let ((me (user-login-name)))
3039     (equal me (clearcase-fprop-owner-of-checkout file))))
3040
3041 (defun clearcase-assert-file-ok-to-checkin (file)
3042   "Raise an exception if FILE is not suitable for checkin."
3043   (if (not (clearcase-file-ok-to-checkin file))
3044       (error "You cannot checkin %s" file)))
3045
3046 (defun clearcase-commented-checkin (file &optional comment)
3047   "Check-in FILE with COMMENT. If the comment is omitted,
3048 a buffer is popped up to accept one."
3049
3050   (clearcase-assert-file-ok-to-checkin file)
3051
3052   (if (null comment)
3053       ;; If no comment supplied, go and get one..
3054       ;;
3055       (progn
3056         (clearcase-comment-start-entry (file-name-nondirectory file)
3057                                        "Enter a checkin comment."
3058                                        'clearcase-commented-checkin
3059                                        (list file)
3060                                        (find-file-noselect file)
3061                                        (clearcase-fprop-comment file))
3062
3063         ;; Also display a diff, if that is the custom:
3064         ;;
3065         (if (and (not (file-directory-p file))
3066                  clearcase-diff-on-checkin)
3067             (save-excursion
3068               (let ((tmp-buffer (current-buffer)))
3069                 (message "Running diff...")
3070                 (clearcase-diff-file-with-version file
3071                                                   (clearcase-fprop-predecessor-version file))
3072                 (message "Running diff...done")
3073                 (set-buffer "*clearcase*")
3074                 (if (get-buffer "*clearcase-diff*")
3075                     (kill-buffer "*clearcase-diff*"))
3076                 (rename-buffer "*clearcase-diff*")
3077                 (pop-to-buffer tmp-buffer)))))
3078
3079     ;; ...otherwise perform the operation.
3080     ;;
3081     (message "Checking in %s..." file)
3082     (save-excursion
3083       ;; Sync the buffer to disk, and get local value of clearcase-checkin-arguments
3084       ;;
3085       (let ((buffer-on-file (find-buffer-visiting file)))
3086         (if buffer-on-file
3087             (progn
3088               (set-buffer buffer-on-file)
3089               (clearcase-sync-to-disk))))
3090       (clearcase-ct-do-cleartool-command "ci"
3091                                          file
3092                                          comment
3093                                          clearcase-checkin-arguments))
3094     (message "Checking in %s...done" file)
3095
3096     ;; Resync.
3097     ;;
3098     (clearcase-sync-from-disk file t)))
3099
3100 (defun clearcase-commented-checkin-seq (files &optional comment)
3101   "Checkin a sequence of FILES. If COMMENT is supplied it will be
3102 used, otherwise the user will be prompted to enter one."
3103
3104   ;; Check they're all in the right state to be checked-in.
3105   ;;
3106   (mapcar
3107    (function clearcase-assert-file-ok-to-checkin)
3108    files)
3109
3110   (if (null comment)
3111       ;; No comment supplied, go and get one...
3112       ;;
3113       (clearcase-comment-start-entry "checkin"
3114                                      "Enter checkin comment."
3115                                      'clearcase-commented-checkin-seq
3116                                      (list files))
3117     ;; ...otherwise operate.
3118     ;;
3119     (mapcar
3120      (function
3121       (lambda (file)
3122         (clearcase-commented-checkin file comment)))
3123      files)))
3124
3125 ;;}}}
3126
3127 ;;{{{ Checkout
3128
3129 (defun clearcase-file-ok-to-checkout (file)
3130   "Test if FILE is suitable for checkout."
3131   (let ((mtype (clearcase-fprop-mtype file)))
3132     (and (or (eq 'version mtype)
3133              (eq 'directory-version mtype)
3134              (clearcase-fprop-hijacked file))
3135          (not (clearcase-fprop-checked-out file)))))
3136
3137 (defun clearcase-assert-file-ok-to-checkout (file)
3138   "Raise an exception if FILE is not suitable for checkout."
3139   (if (not (clearcase-file-ok-to-checkout file))
3140       (error "You cannot checkout %s" file)))
3141
3142 ;; nyi: Offer to setact if appropriate
3143
3144 (defun clearcase-commented-checkout (file &optional comment)
3145   "Check-out FILE with COMMENT. If the comment is omitted,
3146 a buffer is popped up to accept one."
3147
3148   (clearcase-assert-file-ok-to-checkout file)
3149
3150   (if (and (null comment)
3151            (not clearcase-suppress-checkout-comments))
3152       ;; If no comment supplied, go and get one...
3153       ;;
3154       (clearcase-comment-start-entry (file-name-nondirectory file)
3155                                      "Enter a checkout comment."
3156                                      'clearcase-commented-checkout
3157                                      (list file)
3158                                      (find-file-noselect file))
3159
3160     ;; ...otherwise perform the operation.
3161     ;;
3162     (message "Checking out %s..." file)
3163     ;; Change buffers to get local value of clearcase-checkin-arguments.
3164     ;;
3165     (save-excursion
3166       (set-buffer (or (find-buffer-visiting file)
3167                       (current-buffer)))
3168       (clearcase-ct-do-cleartool-command "co"
3169                                          file
3170                                          comment
3171                                          clearcase-checkout-arguments))
3172     (message "Checking out %s...done" file)
3173
3174     ;; Resync.
3175     ;;
3176     (clearcase-sync-from-disk file t)))
3177
3178
3179 (defun clearcase-commented-checkout-seq (files &optional comment)
3180   "Checkout a sequence of FILES. If COMMENT is supplied it will be
3181 used, otherwise the user will be prompted to enter one."
3182
3183   (mapcar
3184    (function clearcase-assert-file-ok-to-checkout)
3185    files)
3186
3187   (if (and (null comment)
3188            (not clearcase-suppress-checkout-comments))
3189       ;; No comment supplied, go and get one...
3190       ;;
3191       (clearcase-comment-start-entry "checkout"
3192                                      "Enter a checkout comment."
3193                                      'clearcase-commented-checkout-seq
3194                                      (list files))
3195     ;; ...otherwise operate.
3196     ;;
3197     (mapcar
3198      (function
3199       (lambda (file)
3200         (clearcase-commented-checkout file comment)))
3201      files)))
3202
3203 ;;}}}
3204
3205 ;;{{{ Uncheckout
3206
3207 (defun clearcase-file-ok-to-uncheckout (file)
3208   "Test if FILE is suitable for uncheckout."
3209   (equal (user-login-name)
3210          (clearcase-fprop-owner-of-checkout file)))
3211
3212 (defun clearcase-assert-file-ok-to-uncheckout (file)
3213   "Raise an exception if FILE is not suitable for uncheckout."
3214   (if (not (clearcase-file-ok-to-uncheckout file))
3215       (error "You cannot uncheckout %s" file)))
3216
3217 (defun cleartool-unco-parse-for-kept-file (ret)
3218   ;;Private version of "foo" saved in "foo.keep.1"
3219   (if (string-match "^Private version of .* saved in \"\\([^\"]+\\)\"\\.$" ret)
3220       (substring ret (match-beginning 1) (match-end 1))
3221     nil))
3222
3223 (defun clearcase-uncheckout (file)
3224   "Uncheckout FILE."
3225
3226   (clearcase-assert-file-ok-to-uncheckout file)
3227
3228   ;; If it has changed since checkout, insist the user confirm.
3229   ;;
3230   (if (and (not (file-directory-p file))
3231            (clearcase-file-appears-modified-since-checkout-p file)
3232            (not clearcase-suppress-confirm)
3233            (not (yes-or-no-p (format "Really discard changes to %s ?" file))))
3234       (message "Uncheckout of %s cancelled" file)
3235
3236     ;; Go ahead and unco.
3237     ;;
3238     (message "Cancelling checkout of %s..." file)
3239     ;; nyi:
3240     ;;  - Prompt for -keep or -rm
3241     ;;  - offer to remove /0 branches
3242     ;;
3243     (let* ((ret (clearcase-ct-blocking-call "unco"
3244                                             (if clearcase-keep-uncheckouts
3245                                                 "-keep"
3246                                               "-rm")
3247                                             file))
3248            ;; Discover the name of the saved.
3249            ;;
3250            (kept-file (if clearcase-keep-uncheckouts
3251                           (cleartool-unco-parse-for-kept-file ret)
3252                         nil)))
3253
3254       (if kept-file
3255           (message "Checkout of %s cancelled (saved in %s)"
3256                    (file-name-nondirectory kept-file)
3257                    file)
3258         (message "Cancelling checkout of %s...done" file))
3259
3260       ;; Sync any buffers over the file itself.
3261       ;;
3262       (clearcase-sync-from-disk file t)
3263
3264       ;; Update any dired buffers as to the existence of the kept file.
3265       ;;
3266       (if kept-file
3267           (dired-relist-file kept-file)))))
3268
3269 (defun clearcase-uncheckout-seq (files)
3270   "Uncheckout a sequence of FILES."
3271
3272   (mapcar
3273    (function clearcase-assert-file-ok-to-uncheckout)
3274    files)
3275
3276   (mapcar
3277    (function clearcase-uncheckout)
3278    files))
3279
3280 ;;}}}
3281
3282 ;;{{{ Describe
3283
3284 (defun clearcase-describe (file)
3285   "Give a ClearCase description of FILE."
3286
3287   (clearcase-utl-populate-and-view-buffer
3288    "*clearcase*"
3289    (list file)
3290    (function
3291     (lambda (file)
3292       (clearcase-ct-do-cleartool-command "describe" file 'unused)))))
3293
3294 (defun clearcase-describe-seq (files)
3295   "Give a ClearCase description of the sequence of FILES."
3296   (error "Not yet implemented"))
3297
3298 ;;}}}
3299
3300 ;;{{{ Mkbrtype
3301
3302 (defun clearcase-commented-mkbrtype (typename &optional comment)
3303   (if (null comment)
3304       (clearcase-comment-start-entry (format "mkbrtype:%s" typename)
3305                                      "Enter a comment for the new branch type."
3306                                      'clearcase-commented-mkbrtype
3307                                      (list typename))
3308     (clearcase-with-tempfile
3309      comment-file
3310      (write-region comment nil comment-file nil 'noprint)
3311      (let ((qualified-typename typename))
3312        (if (not (string-match "@" typename))
3313            (setq qualified-typename
3314                  (format "%s@%s" typename default-directory)))
3315
3316        (clearcase-ct-cleartool-cmd "mkbrtype"
3317                                    "-cfile"
3318                                    (clearcase-path-native comment-file)
3319                                    qualified-typename)))))
3320
3321 ;;}}}
3322
3323 ;;{{{ Browse vtree (using Dired Mode)
3324
3325 (defun clearcase-file-ok-to-browse (file)
3326   (and file
3327        (or (equal 'version (clearcase-fprop-mtype file))
3328            (equal 'directory-version (clearcase-fprop-mtype file)))
3329        (clearcase-file-is-in-mvfs-p file)))
3330
3331 (defun clearcase-browse-vtree (file)
3332   (if (not (clearcase-fprop-file-is-version-p file))
3333       (error "%s is not a Clearcase element" file))
3334
3335   (if (not (clearcase-file-is-in-mvfs-p file))
3336       (error "File is not in MVFS"))
3337
3338   (let* ((version-path (clearcase-vxpath-cons-vxpath
3339                         file
3340                         (or (clearcase-vxpath-version-part file)
3341                             (clearcase-fprop-version file))))
3342          ;; nyi: Can't seem to get latest first here.
3343          ;;
3344          (dired-listing-switches (concat dired-listing-switches
3345                                          "rt"))
3346
3347          (branch-path (clearcase-vxpath-branch version-path))
3348
3349          ;; Position cursor to the version we came from.
3350          ;; If it was checked-out, go to predecessor.
3351          ;;
3352          (version-number (clearcase-vxpath-version
3353                           (if (clearcase-fprop-checked-out file)
3354                               (clearcase-fprop-predecessor-version file)
3355                             version-path))))
3356
3357     (if (file-exists-p version-path)
3358         (progn
3359           ;; Invoke dired on the directory of the version branch.
3360           ;;
3361           (dired branch-path)
3362
3363           (clearcase-dired-sort-by-date)
3364
3365           (if (re-search-forward (concat "[ \t]+"
3366                                          "\\("
3367                                          (regexp-quote version-number)
3368                                          "\\)"
3369                                          "$")
3370                                  nil
3371                                  t)
3372               (goto-char (match-beginning 1))))
3373       (dired (concat file clearcase-vxpath-glue))
3374
3375       ;; nyi: We want ANY directory in the history tree to appear with
3376       ;;      newest first. Probably requires a hook to dired mode.
3377       ;;
3378       (clearcase-dired-sort-by-date))))
3379
3380 ;;}}}
3381
3382 ;;{{{ List history
3383
3384 (defun clearcase-list-history (file)
3385   "List the change history of FILE.
3386
3387 FILE can be a file or a directory. If it is a directory, only the information
3388 on the directory element itself is listed, not on its contents."
3389
3390   (let ((mtype (clearcase-fprop-mtype file)))
3391     (if (or (eq mtype 'version)
3392             (eq mtype 'directory-version))
3393         (progn
3394           (message "Listing element history...")
3395
3396           (clearcase-utl-populate-and-view-buffer
3397            "*clearcase*"
3398            (list file)
3399            (function
3400             (lambda (file)
3401               (clearcase-ct-do-cleartool-command "lshistory"
3402                                                  file
3403                                                  'unused
3404                                                  (if (eq mtype 'directory-version)
3405                                                      (list "-d")))
3406               (setq default-directory (file-name-directory file))
3407               (while (looking-at "=3D*\n")
3408                 (delete-char (- (match-end 0) (match-beginning 0)))
3409                 (forward-line -1))
3410               (goto-char (point-min))
3411               (if (looking-at "[\b\t\n\v\f\r ]+")
3412                   (delete-char (- (match-end 0) (match-beginning 0)))))))
3413           (message "Listing element history...done"))
3414
3415       (error "%s is not a ClearCase element" file))))
3416
3417 ;;}}}
3418
3419 ;;{{{ Diff/cmp
3420
3421 (defun clearcase-files-are-identical (f1 f2)
3422   "Test if FILE1 and FILE2 have identical contents."
3423
3424   (clearcase-when-debugging
3425    (if (not (file-exists-p f1))
3426        (error "%s  non-existent" f1))
3427    (if (not (file-exists-p f2))
3428        (error "%s  non-existent" f2)))
3429
3430   (zerop (call-process "cleardiff" nil nil nil "-status_only" f1 f2)))
3431
3432 (defun clearcase-diff-files (file1 file2)
3433   "Run cleardiff on FILE1 and FILE2 and display the differences."
3434   (if clearcase-use-normal-diff
3435       (clearcase-do-command 2
3436                             clearcase-normal-diff-program
3437                             file2
3438                             (append clearcase-normal-diff-arguments
3439                                     (list file1)))
3440     (clearcase-do-command 2
3441                           "cleardiff"
3442                           file2
3443                           (list "-diff_format" file1)))
3444   (let ((diff-size  (save-excursion
3445                       (set-buffer "*clearcase*")
3446                       (buffer-size))))
3447     (if (zerop diff-size)
3448         (message "No differences")
3449       (clearcase-port-view-buffer-other-window "*clearcase*")
3450       (goto-char 0)
3451       (shrink-window-if-larger-than-buffer))))
3452
3453 ;;}}}
3454
3455 ;;{{{ What rule
3456
3457 (defun clearcase-what-rule (file)
3458   (let ((result (clearcase-ct-cleartool-cmd "ls"
3459                                             "-d"
3460                                             (clearcase-path-native file))))
3461     (if (string-match "Rule: \\(.*\\)\n" result)
3462         (message (substring result
3463                             ;; Be a little more verbose
3464                             (match-beginning 0) (match-end 1)))
3465       (error result))))
3466
3467 ;;}}}
3468
3469 ;;}}}
3470
3471 ;;{{{ File property cache
3472
3473 ;; ClearCase properties of files are stored in a vector in a hashtable with the
3474 ;; absolute-filename (with no trailing slashes) as the lookup key.
3475 ;;
3476 ;; Properties are:
3477 ;;
3478 ;; [0] truename            : string
3479 ;; [1] mtype               : { nil, view-private-object, version,
3480 ;;                             directory-version, file-element,
3481 ;;                             dir-element, derived-object
3482 ;;                           }
3483 ;; [2] checked-out         : boolean
3484 ;; [3] reserved            : boolean
3485 ;; [4] version             : string
3486 ;; [5] predecessor-version : string
3487 ;; [6] oid                 : string
3488 ;; [7] user                : string
3489 ;; [8] date                : string (yyyymmdd.hhmmss)
3490 ;; [9] time-last-described : (N, N, N) time when the properties were last read
3491 ;;                           from ClearCase
3492 ;; [10] viewtag            : string
3493 ;; [11] comment            : string
3494 ;; [12] slink-text         : string (empty string if not symlink)
3495 ;; [13] hijacked           : boolean
3496
3497 ;; nyi: other possible properties to record:
3498 ;;      mtime when last described (lets us know when the cached properties
3499 ;;      might be stale)
3500
3501 ;;{{{ Debug code
3502
3503 (defun clearcase-fprop-unparse-properties (properties)
3504   "Return a string suitable for printing PROPERTIES."
3505   (concat
3506    (format "truename:            %s\n" (aref properties 0))
3507    (format "mtype:               %s\n" (aref properties 1))
3508    (format "checked-out:         %s\n" (aref properties 2))
3509    (format "reserved:            %s\n" (aref properties 3))
3510    (format "version:             %s\n" (aref properties 4))
3511    (format "predecessor-version: %s\n" (aref properties 5))
3512    (format "oid:                 %s\n" (aref properties 6))
3513    (format "user:                %s\n" (aref properties 7))
3514    (format "date:                %s\n" (aref properties 8))
3515    (format "time-last-described: %s\n" (current-time-string (aref properties 9)))
3516    (format "viewtag:             %s\n" (aref properties 10))
3517    (format "comment:             %s\n" (aref properties 11))
3518    (format "slink-text:          %s\n" (aref properties 12))
3519    (format "hijacked:            %s\n" (aref properties 13))))
3520
3521 (defun clearcase-fprop-display-properties (file)
3522   "Display the recorded ClearCase properties of FILE."
3523   (interactive "F")
3524   (let* ((abs-file (expand-file-name file))
3525          (properties (clearcase-fprop-lookup-properties abs-file)))
3526     (if properties
3527         (let ((unparsed-properties (clearcase-fprop-unparse-properties properties)))
3528           (clearcase-utl-populate-and-view-buffer
3529            "*clearcase*"
3530            nil
3531            (function (lambda ()
3532                        (insert unparsed-properties)))))
3533       (error "Properties for %s not stored" file))))
3534
3535 (defun clearcase-fprop-dump-to-current-buffer ()
3536   "Dump to the current buffer the table recording ClearCase properties of files."
3537   (interactive)
3538   (insert (format "File describe count: %s\n" clearcase-fprop-describe-count))
3539   (mapatoms
3540    (function
3541     (lambda (symbol)
3542       (let ((properties (symbol-value symbol)))
3543         (insert "\n"
3544                 (format "key:                 %s\n" (symbol-name symbol))
3545                 "\n"
3546                 (clearcase-fprop-unparse-properties properties)))))
3547    clearcase-fprop-hashtable)
3548   (insert "\n"))
3549
3550 (defun clearcase-fprop-dump ()
3551   (interactive)
3552   (clearcase-utl-populate-and-view-buffer
3553    "*clearcase*"
3554    nil
3555    (function (lambda ()
3556                (clearcase-fprop-dump-to-current-buffer)))))
3557
3558 ;;}}}
3559
3560 (defvar clearcase-fprop-hashtable (make-vector 31 0)
3561   "Obarray for per-file ClearCase properties.")
3562
3563 (defun clearcase-fprop-canonicalise-path (filename)
3564   ;; We want DIR/y and DIR\y to map to the same cache entry on ms-windows.
3565   ;; We want DIR and DIR/ (and on windows DIR\) to map to the same cache entry.
3566   ;;
3567   ;; However, on ms-windows avoid canonicalising X:/ to X: because, for some
3568   ;; reason, cleartool+desc fails on X:, but works on X:/
3569   ;;
3570   (setq filename (clearcase-path-canonicalise-slashes filename))
3571   (if (and clearcase-on-mswindows
3572            (string-match (concat "^" "[A-Za-z]:" clearcase-pname-sep-regexp "$")
3573                          filename))
3574       filename
3575     (clearcase-utl-strip-trailing-slashes filename)))
3576
3577 (defun clearcase-fprop-clear-all-properties ()
3578   "Delete all entries in the clearcase-fprop-hashtable."
3579   (setq clearcase-fprop-hashtable (make-vector 31 0)))
3580
3581 (defun clearcase-fprop-store-properties (file properties)
3582   "For FILE, store its ClearCase PROPERTIES in the clearcase-fprop-hashtable."
3583   (assert (file-name-absolute-p file))
3584   (set (intern (clearcase-fprop-canonicalise-path file)
3585                clearcase-fprop-hashtable) properties))
3586
3587 (defun clearcase-fprop-unstore-properties (file)
3588   "For FILE, delete its entry in the clearcase-fprop-hashtable."
3589   (assert (file-name-absolute-p file))
3590   (unintern (clearcase-fprop-canonicalise-path file) clearcase-fprop-hashtable))
3591
3592 (defun clearcase-fprop-lookup-properties (file)
3593   "For FILE, lookup and return its ClearCase properties from the
3594 clearcase-fprop-hashtable."
3595   (assert (file-name-absolute-p file))
3596   (symbol-value (intern-soft (clearcase-fprop-canonicalise-path file)
3597                              clearcase-fprop-hashtable)))
3598
3599 (defun clearcase-fprop-get-properties (file)
3600   "For FILE, make sure its ClearCase properties are in the hashtable
3601 and then return them."
3602   (or (clearcase-fprop-lookup-properties file)
3603       (let ((properties
3604              (condition-case signal-info
3605                  (clearcase-fprop-read-properties file)
3606                (error
3607                 (progn
3608                   (clearcase-trace (format "(clearcase-fprop-read-properties %s) signalled error: %s"
3609                                            file
3610                                            (cdr signal-info)))
3611                   (make-vector 31 nil))))))
3612         (clearcase-fprop-store-properties file properties)
3613         properties)))
3614
3615 (defun clearcase-fprop-truename (file)
3616   "For FILE, return its \"truename\" ClearCase property."
3617   (aref (clearcase-fprop-get-properties file) 0))
3618
3619 (defun clearcase-fprop-mtype (file)
3620   "For FILE, return its \"mtype\" ClearCase property."
3621   (aref (clearcase-fprop-get-properties file) 1))
3622
3623 (defun clearcase-fprop-checked-out (file)
3624   "For FILE, return its \"checked-out\" ClearCase property."
3625   (aref (clearcase-fprop-get-properties file) 2))
3626
3627 (defun clearcase-fprop-reserved (file)
3628   "For FILE, return its \"reserved\" ClearCase property."
3629   (aref (clearcase-fprop-get-properties file) 3))
3630
3631 (defun clearcase-fprop-version (file)
3632   "For FILE, return its \"version\" ClearCase property."
3633   (aref (clearcase-fprop-get-properties file) 4))
3634
3635 (defun clearcase-fprop-predecessor-version (file)
3636   "For FILE, return its \"predecessor-version\" ClearCase property."
3637   (aref (clearcase-fprop-get-properties file) 5))
3638
3639 (defun clearcase-fprop-oid (file)
3640   "For FILE, return its \"oid\" ClearCase property."
3641   (aref (clearcase-fprop-get-properties file) 6))
3642
3643 (defun clearcase-fprop-user (file)
3644   "For FILE, return its \"user\" ClearCase property."
3645   (aref (clearcase-fprop-get-properties file) 7))
3646
3647 (defun clearcase-fprop-date (file)
3648   "For FILE, return its \"date\" ClearCase property."
3649   (aref (clearcase-fprop-get-properties file) 8))
3650
3651 (defun clearcase-fprop-time-last-described (file)
3652   "For FILE, return its \"time-last-described\" ClearCase property."
3653   (aref (clearcase-fprop-get-properties file) 9))
3654
3655 (defun clearcase-fprop-viewtag (file)
3656   "For FILE, return its \"viewtag\" ClearCase property."
3657   (aref (clearcase-fprop-get-properties file) 10))
3658
3659 (defun clearcase-fprop-comment (file)
3660   "For FILE, return its \"comment\" ClearCase property."
3661   (aref (clearcase-fprop-get-properties file) 11))
3662
3663 (defun clearcase-fprop-vob-slink-text (file)
3664   "For FILE, return its \"slink-text\" ClearCase property."
3665   (aref (clearcase-fprop-get-properties file) 12))
3666
3667 (defun clearcase-fprop-hijacked (file)
3668   "For FILE, return its \"hijacked\" ClearCase property."
3669   (aref (clearcase-fprop-get-properties file) 13))
3670
3671 (defun clearcase-fprop-set-comment (file comment)
3672   "For FILE, set its \"comment\" ClearCase property to COMMENT."
3673   (aset (clearcase-fprop-get-properties file) 11 comment))
3674
3675 (defun clearcase-fprop-owner-of-checkout (file)
3676   "For FILE, return whether the current user has it checked-out."
3677   (if (clearcase-fprop-checked-out file)
3678       (clearcase-fprop-user file)
3679     nil))
3680
3681 (defun clearcase-fprop-file-is-vob-slink-p (object-name)
3682   (not (zerop (length (clearcase-fprop-vob-slink-text object-name)))))
3683
3684 (defun clearcase-fprop-file-is-version-p (object-name)
3685   (if object-name
3686       (let ((mtype (clearcase-fprop-mtype object-name)))
3687         (or (eq 'version mtype)
3688             (eq 'directory-version mtype)))))
3689
3690 ;; Read the object's ClearCase properties using cleartool and the Lisp reader.
3691 ;;
3692 ;; nyi: for some reason the \n before the %c necessary here so avoid confusing the
3693 ;;      cleartool/tq interface.  Completely mysterious. Arrived at by
3694 ;;      trial and error.
3695 ;;
3696 (defvar clearcase-fprop-fmt-string
3697
3698   ;; Yuck.  Different forms of quotation are needed here apparently to deal with
3699   ;; all the various ways of spawning sub-process on the the various platforms
3700   ;; (XEmacs vs. GnuEmacs, Win32 vs. Unix, Cygwin-built vs. native-built).
3701   ;;
3702   (if clearcase-on-mswindows
3703       (if clearcase-xemacs-p
3704           ;; XEmacs/Windows
3705           ;;
3706           (if clearcase-on-cygwin
3707               ;; Cygwin build
3708               ;;
3709               "[nil \\\"%m\\\" \\\"%f\\\" \\\"%Rf\\\" \\\"%Sn\\\" \\\"%PSn\\\" \\\"%On\\\" \\\"%u\\\" \\\"%Nd\\\" nil nil nil \\\"%[slink_text]p\\\"  nil ]\\n%c"
3710             ;; Native build
3711             ;;
3712             "[nil \\\"%m\\\" \\\"%f\\\" \\\"%Rf\\\" \\\"%Sn\\\" \\\"%PSn\\\" \\\"%On\\\" \\\"%u\\\" \\\"%Nd\\\" nil nil nil \\\"%[slink_text]p\\\" nil]\n%c")
3713
3714         ;; GnuEmacs/Windows
3715         ;;
3716         "[nil \"%m\" \"%f\" \"%Rf\" \"%Sn\" \"%PSn\" \"%On\" \"%u\" \"%Nd\" nil nil nil \"%[slink_text]p\" nil]\\n%c")
3717
3718     ;; Unix
3719     ;;
3720     "'[nil \"%m\" \"%f\" \"%Rf\" \"%Sn\" \"%PSn\" \"%On\" \"%u\" \"%Nd\" nil nil nil \"%[slink_text]p\" nil]\\n%c'")
3721
3722   "Format for cleartool+describe command when reading the
3723 ClearCase properties of a file")
3724
3725 (defvar clearcase-fprop-describe-count 0
3726   "Count the number of times clearcase-fprop-read-properties is called")
3727
3728 (defun clearcase-fprop-read-properties (file)
3729   "Invoke the cleartool+describe command to obtain the ClearCase
3730 properties of FILE."
3731   (assert (file-name-absolute-p file))
3732   (let* ((truename (clearcase-fprop-canonicalise-path (file-truename (expand-file-name file)))))
3733
3734     ;; If the object doesn't exist, signal an error
3735     ;;
3736     (if (or (not (file-exists-p (clearcase-vxpath-element-part file)))
3737             (not (file-exists-p (clearcase-vxpath-element-part truename))))
3738         (error "File doesn't exist: %s" file)
3739
3740       ;; Run cleartool+ describe and capture the output as a string:
3741       ;;
3742       (let ((desc-string (clearcase-ct-cleartool-cmd "desc"
3743                                                      "-fmt"
3744                                                      clearcase-fprop-fmt-string
3745                                                      (clearcase-path-native truename))))
3746         (setq clearcase-fprop-describe-count (1+ clearcase-fprop-describe-count))
3747
3748         ;;(clearcase-trace (format "desc of %s <<<<" truename))
3749         ;;(clearcase-trace desc-string)
3750         ;;(clearcase-trace (format "desc of %s >>>>" truename))
3751
3752         ;; Read all but the comment, using the Lisp reader, and then copy
3753         ;; what's left as the comment.  We don't try to use the Lisp reader to
3754         ;; fetch the comment to avoid problems with quotation.
3755         ;;
3756         ;; nyi: it would be nice if we could make cleartool use "/" as pname-sep,
3757         ;;      because read-from-string will barf on imbedded "\".  For now
3758         ;;      run clearcase-path-canonicalise-slashes over the cleartool
3759         ;;      output before invoking the Lisp reader.
3760         ;;
3761         (let* ((first-read (read-from-string (clearcase-path-canonicalise-slashes desc-string)))
3762                (result (car first-read))
3763                (bytes-read (cdr first-read))
3764                (comment (substring desc-string (1+ bytes-read)))) ;; skip \n
3765
3766           ;; Plug in the slots I left empty:
3767           ;;
3768           (aset result 0 truename)
3769           (aset result 9 (current-time))
3770
3771           (aset result 11 comment)
3772
3773           ;; Convert mtype to an enumeration:
3774           ;;
3775           (let ((mtype-string (aref result 1)))
3776             (cond
3777              ((string= mtype-string "version")
3778               (aset result 1 'version))
3779
3780              ((string= mtype-string "directory version")
3781               (aset result 1 'directory-version))
3782
3783              ((string= mtype-string "view private object")
3784               (aset result 1 'view-private-object)
3785
3786               ;; If we're in a snapshot see if it is hijacked by running
3787               ;; ct+desc FILE@@. No error indicates it's hijacked.
3788               ;;
3789               (if (clearcase-file-would-be-in-snapshot-p truename)
3790                   (aset result 13
3791                         (condition-case nil
3792                             (stringp
3793                              (clearcase-ct-cleartool-cmd
3794                               "desc"
3795                               "-short"
3796                               (concat (clearcase-path-native truename)
3797                                       clearcase-vxpath-glue)))
3798                           (error nil)))))
3799
3800              ((string= mtype-string "file element")
3801               (aset result 1 'file-element))
3802
3803              ((string= mtype-string "directory element")
3804               (aset result 1 'directory-element))
3805
3806              ((string= mtype-string "derived object")
3807               (aset result 1 'derived-object))
3808
3809              ;; For now treat checked-in DOs as versions.
3810              ;;
3811              ((string= mtype-string "derived object version")
3812               (aset result 1 'version))
3813
3814              ;; On NT, coerce the mtype of symlinks into that
3815              ;; of their targets.
3816              ;;
3817              ;; nyi: I think this is approximately right.
3818              ;;
3819              ((and (string= mtype-string "symbolic link")
3820                    clearcase-on-mswindows)
3821               (if (file-directory-p truename)
3822                   (aset result 1 'directory-version)
3823                 (aset result 1 'version)))
3824
3825              ;; We get this on paths like foo.c@@/main
3826              ;;
3827              ((string= mtype-string "branch")
3828               (aset result 1 'branch))
3829
3830              ((string= mtype-string "**null meta type**")
3831               (aset result 1 nil))
3832
3833              (t
3834               (error "Unknown mtype returned by cleartool+describe: %s"
3835                      mtype-string))))
3836
3837           ;; nyi: possible efficiency win: only evaluate the viewtag on demand.
3838           ;;
3839           (if (aref result 1)
3840               (aset result 10 (clearcase-file-viewtag truename)))
3841
3842           ;; Convert checked-out field to boolean:
3843           ;;
3844           (aset result 2 (not (zerop (length (aref result 2)))))
3845
3846           ;; Convert reserved field to boolean:
3847           ;;
3848           (aset result 3 (string= "reserved" (aref result 3)))
3849
3850           ;; Return the array of properties.
3851           ;;
3852           result)))))
3853
3854 ;;}}}
3855
3856 ;;{{{ View property cache
3857
3858 ;; ClearCase properties of views are stored in a vector in a hashtable
3859 ;; with the viewtag as the lookup key.
3860 ;;
3861 ;; Properties are:
3862 ;;
3863 ;; [0] ucm                 : boolean
3864 ;; [1] stream              : string
3865 ;; [2] pvob                : string
3866 ;; [3] activities          : list of strings
3867 ;; [4] current-activity    : string
3868
3869 ;;{{{ Debug code
3870
3871 (defun clearcase-vprop-dump-to-current-buffer ()
3872   "Dump to the current buffer the table recording ClearCase properties of views."
3873   (insert (format "View describe count: %s\n" clearcase-vprop-describe-count))
3874   (mapatoms
3875    (function
3876     (lambda (symbol)
3877       (let ((properties (symbol-value symbol)))
3878         (insert "\n"
3879                 (format "viewtag:             %s\n" (symbol-name symbol))
3880                 "\n"
3881                 (clearcase-vprop-unparse-properties properties)))))
3882    clearcase-vprop-hashtable)
3883   (insert "\n"))
3884
3885 (defun clearcase-vprop-dump ()
3886   (interactive)
3887   (clearcase-utl-populate-and-view-buffer
3888    "*clearcase*"
3889    nil
3890    (function (lambda ()
3891                (clearcase-vprop-dump-to-current-buffer)))))
3892
3893 (defun clearcase-vprop-unparse-properties (properties)
3894   "Return a string suitable for printing PROPERTIES."
3895   (concat
3896    (format "ucm:                 %s\n" (aref properties 0))
3897    (format "stream:              %s\n" (aref properties 1))
3898    (format "pvob:                %s\n" (aref properties 2))
3899    (format "activities:          %s\n" (aref properties 3))
3900    (format "current-activity:    %s\n" (aref properties 4))))
3901
3902 ;;}}}
3903
3904 ;;{{{ Asynchronously fetching view properties:
3905
3906 (defvar clearcase-vprop-timer nil)
3907 (defvar clearcase-vprop-work-queue nil)
3908
3909 (defun clearcase-vprop-schedule-work (viewtag)
3910   ;; Add to the work queue.
3911   ;;
3912   (setq clearcase-vprop-work-queue (cons viewtag
3913                                              clearcase-vprop-work-queue))
3914   ;; Create the timer if necessary.
3915   ;;
3916   (if (null clearcase-vprop-timer)
3917       (if clearcase-xemacs-p
3918           ;; Xemacs
3919           ;;
3920           (setq clearcase-vprop-timer
3921                 (run-with-idle-timer 5 t 'clearcase-vprop-timer-function))
3922         ;; FSF Emacs
3923         ;;
3924         (progn
3925           (setq clearcase-vprop-timer (timer-create))
3926           (timer-set-function clearcase-vprop-timer 'clearcase-vprop-timer-function)
3927           (timer-set-idle-time clearcase-vprop-timer 5)
3928           (timer-activate-when-idle clearcase-vprop-timer)))))
3929
3930 (defun clearcase-vprop-timer-function ()
3931   ;; Process the work queue and empty it.
3932   ;;
3933   (mapcar (function (lambda (viewtag)
3934                       (clearcase-vprop-get-properties viewtag)))
3935           clearcase-vprop-work-queue)
3936   (setq clearcase-vprop-work-queue nil)
3937
3938   ;; Cancel the timer.
3939   ;;
3940   (cancel-timer clearcase-vprop-timer)
3941   (setq clearcase-vprop-timer nil))
3942
3943 ;;}}}
3944
3945 (defvar clearcase-vprop-hashtable (make-vector 31 0)
3946   "Obarray for per-view ClearCase properties.")
3947
3948 (defun clearcase-vprop-clear-all-properties ()
3949   "Delete all entries in the clearcase-vprop-hashtable."
3950   (setq clearcase-vprop-hashtable (make-vector 31 0)))
3951
3952 (defun clearcase-vprop-store-properties (viewtag properties)
3953   "For VIEW, store its ClearCase PROPERTIES in the clearcase-vprop-hashtable."
3954   (set (intern viewtag clearcase-vprop-hashtable) properties))
3955
3956 (defun clearcase-vprop-unstore-properties (viewtag)
3957   "For VIEWTAG, delete its entry in the clearcase-vprop-hashtable."
3958   (unintern viewtag clearcase-vprop-hashtable))
3959
3960 (defun clearcase-vprop-lookup-properties (viewtag)
3961   "For VIEWTAG, lookup and return its ClearCase properties from the
3962 clearcase-vprop-hashtable."
3963   (symbol-value (intern-soft viewtag clearcase-vprop-hashtable)))
3964
3965 (defun clearcase-vprop-get-properties (viewtag)
3966   "For VIEWTAG, make sure it's ClearCase properties are in the hashtable
3967 and then return them."
3968   (or (clearcase-vprop-lookup-properties viewtag)
3969       (let ((properties (clearcase-vprop-read-properties viewtag)))
3970         (clearcase-vprop-store-properties viewtag properties)
3971         properties)))
3972
3973 (defun clearcase-vprop-ucm (viewtag)
3974   "For VIEWTAG, return its \"ucm\" ClearCase property."
3975   (aref (clearcase-vprop-get-properties viewtag) 0))
3976
3977 (defun clearcase-vprop-stream (viewtag)
3978   "For VIEWTAG, return its \"stream\" ClearCase property."
3979   (aref (clearcase-vprop-get-properties viewtag) 1))
3980
3981 (defun clearcase-vprop-pvob (viewtag)
3982   "For VIEWTAG, return its \"stream\" ClearCase property."
3983   (aref (clearcase-vprop-get-properties viewtag) 2))
3984
3985 (defun clearcase-vprop-activities (viewtag)
3986   "For VIEWTAG, return its \"activities\" ClearCase property."
3987
3988   ;; If the activity set has been flushed, go and schedule a re-fetch.
3989   ;;
3990   (let ((properties (clearcase-vprop-get-properties viewtag)))
3991     (if (null (aref properties 3))
3992         (aset properties 3 (clearcase-vprop-read-activities-asynchronously viewtag))))
3993
3994   ;; Now poll, waiting for the activities to be available.
3995   ;;
3996   (let ((loop-count 0))
3997     ;; If there is a background process still reading the activities,
3998     ;; wait for it to finish.
3999     ;;
4000     ;; nyi: probably want a timeout here.
4001     ;;
4002     ;; nyi: There seems to be a race on NT in accept-process-output so that
4003     ;;      we would wait forever.
4004     ;;
4005     (if (not clearcase-on-mswindows)
4006         ;; Unix synchronization with the end of the process
4007         ;; which is reading activities.
4008         ;;
4009         (while (bufferp (aref (clearcase-vprop-get-properties viewtag) 3))
4010           (save-excursion
4011             (set-buffer (aref (clearcase-vprop-get-properties viewtag) 3))
4012             (message "Reading activity list...")
4013             (setq loop-count (1+ loop-count))
4014             (accept-process-output clearcase-vprop-async-proc)))
4015
4016       ;; NT synchronization with the end of the process which is reading
4017       ;; activities.
4018       ;;
4019       ;; Unfortunately on NT we can't rely on the process sentinel being called
4020       ;; so we have to explicitly test the process status.
4021       ;;
4022       (while (bufferp (aref (clearcase-vprop-get-properties viewtag) 3))
4023         (message "Reading activity list...")
4024         (save-excursion
4025           (set-buffer (aref (clearcase-vprop-get-properties viewtag) 3))
4026           (if (or (not (processp clearcase-vprop-async-proc))
4027                   (eq 'exit (process-status clearcase-vprop-async-proc)))
4028
4029               ;; The process has finished or gone away and apparently
4030               ;; the sentinel didn't get called which would have called
4031               ;; clearcase-vprop-finish-reading-activities, so call it
4032               ;; explicitly here.
4033               ;;
4034               (clearcase-vprop-finish-reading-activities (current-buffer))
4035
4036             ;; The process is apparently still running, so wait
4037             ;; so more.
4038             (setq loop-count (1+ loop-count))
4039             (sit-for 1)))))
4040
4041     (if (not (zerop loop-count))
4042         (message "Reading activity list...done"))
4043
4044     (aref (clearcase-vprop-get-properties viewtag) 3)))
4045
4046 (defun clearcase-vprop-current-activity (viewtag)
4047   "For VIEWTAG, return its \"current-activity\" ClearCase property."
4048   (aref (clearcase-vprop-get-properties viewtag) 4))
4049
4050 (defun clearcase-vprop-set-activities (viewtag activities)
4051   "For VIEWTAG, set its \"activities\" ClearCase property to ACTIVITIES."
4052   (let ((properties (clearcase-vprop-lookup-properties viewtag)))
4053     ;; We must only set the activities for an existing vprop entry.
4054     ;;
4055     (assert properties)
4056     (aset properties 3 activities)))
4057
4058 (defun clearcase-vprop-flush-activities (viewtag)
4059   "For VIEWTAG, set its \"activities\" ClearCase property to nil,
4060 to cause a future re-fetch."
4061   (clearcase-vprop-set-activities viewtag nil))
4062
4063 (defun clearcase-vprop-set-current-activity (viewtag activity)
4064   "For VIEWTAG, set its \"current-activity\" ClearCase property to ACTIVITY."
4065   (aset (clearcase-vprop-get-properties viewtag) 4 activity))
4066
4067 ;; Read the object's ClearCase properties using cleartool lsview and cleartool lsstream.
4068
4069 (defvar clearcase-vprop-describe-count 0
4070   "Count the number of times clearcase-vprop-read-properties is called")
4071
4072 (defvar clearcase-lsstream-fmt-string
4073   (if clearcase-on-mswindows
4074       (if clearcase-xemacs-p
4075           ;; XEmacs/Windows
4076           ;;
4077           (if clearcase-on-cygwin
4078               ;; Cygwin build
4079               ;;
4080               "[\\\"%n\\\"  \\\"%[master]p\\\" ]"
4081             ;; Native build
4082             ;;
4083             "[\\\"%n\\\"  \\\"%[master]p\\\" ]")
4084         ;; GnuEmacs/Windows
4085         ;;
4086         "[\"%n\"  \"%[master]p\" ]")
4087     ;; Unix
4088     ;;
4089     "'[\"%n\"  \"%[master]p\" ]'"))
4090
4091 (defun clearcase-vprop-read-properties (viewtag)
4092   "Invoke cleartool commands to obtain the ClearCase
4093 properties of VIEWTAG."
4094
4095   ;; We used to use "ct+lsview -properties -full TAG", but this seemed to take
4096   ;; a long time in some circumstances. It appears to be because the
4097   ;; ADM_VIEW_GET_INFO RPC can take up to 60 seconds in certain circumstances
4098   ;; (typically on my laptop with self-contained ClearCase region).
4099
4100   ;; Accordingly, since we don't really need to store snapshotness, the minimum
4101   ;; we really need to discover about a view is whether it is UCM-attached. For
4102   ;; this the much faster ct+lsstream suffices.
4103   ;;
4104   (let* ((result (make-vector 5 nil)))
4105     (if (not clearcase-v3)
4106         (let ((ucm nil)
4107               (stream nil)
4108               (pvob nil)
4109               (activity-names nil)
4110               (activity-titles nil)
4111               (activities nil)
4112               (current-activity nil)
4113               (ret ""))
4114
4115           ;; This was necessary to make sure the "done" message was always
4116           ;; displayed.  Not quite sure why.
4117           ;;
4118           (unwind-protect
4119               (progn
4120                 (message "Reading view properties...")
4121                 (setq ret (clearcase-ct-blocking-call "lsstream" "-fmt"
4122                                                       clearcase-lsstream-fmt-string
4123                                                       "-view" viewtag))
4124
4125                 (setq clearcase-vprop-describe-count (1+ clearcase-vprop-describe-count))
4126
4127                 (if (setq ucm (not (zerop (length ret))))
4128
4129                     ;; It's apparently a UCM view
4130                     ;;
4131                     (let* ((first-read (read-from-string (clearcase-utl-escape-backslashes ret)))
4132                            (array-read (car first-read))
4133                            (bytes-read (cdr first-read)))
4134
4135                       ;; Get stream name
4136                       ;;
4137                       (setq stream (aref array-read 0))
4138
4139                       ;; Get PVOB tag from something like "unix@/vobs/projects"
4140                       ;;
4141                       (let ((s (aref array-read 1)))
4142                         (if (string-match "@" s)
4143                             (setq pvob (substring s (match-end 0)))
4144                           (setq pvob s)))
4145
4146                       ;; Get the activity list and store as a list of (NAME . TITLE) pairs
4147                       ;;
4148                       (setq activities (clearcase-vprop-read-activities-asynchronously viewtag))
4149
4150                       ;; Get the current activity
4151                       ;;
4152                       (let ((name-string (clearcase-ct-blocking-call "lsact" "-cact" "-fmt" "%n"
4153                                                                      "-view" viewtag)))
4154                         (if (not (zerop (length name-string)))
4155                             (setq current-activity name-string)))
4156
4157                       (aset result 0 ucm)
4158                       (aset result 1 stream)
4159                       (aset result 2 pvob)
4160                       (aset result 3 activities)
4161                       (aset result 4 current-activity))))
4162
4163             (message "Reading view properties...done"))))
4164
4165     result))
4166
4167 (defvar clearcase-vprop-async-viewtag nil)
4168 (defvar clearcase-vprop-async-proc nil)
4169 (defun clearcase-vprop-read-activities-asynchronously (viewtag)
4170   (let ((buf-name (format "*clearcase-activities-%s*" viewtag)))
4171     ;; Clean up old instance of the buffer we use to fetch activities:
4172     ;;
4173     (let ((buf (get-buffer buf-name)))
4174       (if buf
4175           (progn
4176             (save-excursion
4177               (set-buffer buf)
4178               (if (and (boundp 'clearcase-vprop-async-proc)
4179                        clearcase-vprop-async-proc)
4180                   (condition-case nil
4181                       (kill-process clearcase-vprop-async-proc)
4182                     (error nil))))
4183             (kill-buffer buf))))
4184
4185     ;; Create a buffer and an associated new process to read activities in the
4186     ;; background. We return the buffer to be stored in the activities field of
4187     ;; the view-properties record. The function clearcase-vprop-activities will
4188     ;; recognise when the asynch fetching is still underway and wait for it to
4189     ;; finish.
4190     ;;
4191     ;; The process has a sentinel function which is supposed to get called when
4192     ;; the process finishes. This sometimes doesn't happen on Windows, so that
4193     ;; clearcase-vprop-activities has to do a bit more work.  (Perhaps a race
4194     ;; exists: the process completes before the sentinel can be set ?)
4195     ;;
4196     (let* ((buf (get-buffer-create buf-name))
4197            (proc (start-process (format "*clearcase-activities-process-%s*" viewtag)
4198                                 buf
4199                                 clearcase-cleartool-path
4200                                 "lsact" "-view" viewtag)))
4201       (process-kill-without-query proc)
4202       (save-excursion
4203         (set-buffer buf)
4204         ;; Create a sentinel to parse and store the activities when the
4205         ;; process finishes. We record the viewtag as a buffer-local
4206         ;; variable so the sentinel knows where to store the activities.
4207         ;;
4208         (set (make-local-variable 'clearcase-vprop-async-viewtag) viewtag)
4209         (set (make-local-variable 'clearcase-vprop-async-proc) proc)
4210         (set-process-sentinel proc 'clearcase-vprop-read-activities-sentinel))
4211       ;; Return the buffer.
4212       ;;
4213       buf)))
4214
4215 (defun clearcase-vprop-read-activities-sentinel (process event-string)
4216   (clearcase-trace "Activity reading process sentinel called")
4217   (if (not (equal "finished\n" event-string))
4218       ;; Failure
4219       ;;
4220       (error "Reading activities failed: %s" event-string))
4221   (clearcase-vprop-finish-reading-activities (process-buffer process)))
4222
4223 (defun clearcase-vprop-finish-reading-activities (buffer)
4224   (let ((activity-list nil))
4225     (message "Parsing view activities...")
4226     (save-excursion
4227       (set-buffer buffer)
4228       (if (or (not (boundp 'clearcase-vprop-async-viewtag))
4229               (null clearcase-vprop-async-viewtag))
4230           (error "Internal error: clearcase-vprop-async-viewtag not set"))
4231
4232       ;; Check that our buffer is the one currently expected to supply the
4233       ;; activities. (Avoid races.)
4234       ;;
4235       (let ((properties (clearcase-vprop-lookup-properties clearcase-vprop-async-viewtag)))
4236         (if (and properties
4237                  (eq buffer (aref properties 3)))
4238             (progn
4239
4240               ;; Parse the buffer, slicing out the 2nd and 4th fields as name and title.
4241               ;;
4242               (goto-char (point-min))
4243               (while (re-search-forward "^[^ \t]+[ \t]+\\([^ \t]+\\)[ \t]+[^ \t]+[ \t]+\"+\\(.*\\)\"$" nil t)
4244                 (let ((id (buffer-substring (match-beginning 1)
4245                                             (match-end 1)))
4246                       (title (buffer-substring (match-beginning 2)
4247                                                (match-end 2))))
4248                   (setq activity-list (cons (cons id title)
4249                                             activity-list))))
4250
4251               ;; We've got activity-list in the reverse order that
4252               ;; cleartool+lsactivity generated them.  I think this is reverse
4253               ;; chronological order, so keep this order since it is more
4254               ;; convenient when setting to an activity.
4255               ;;
4256               ;;(setq activity-list (nreverse activity-list))
4257
4258               (clearcase-vprop-set-activities clearcase-vprop-async-viewtag activity-list))
4259
4260           (kill-buffer buffer))))
4261     (message "Parsing view activities...done")))
4262
4263 ;;{{{ old synchronous activity reader
4264
4265 ;; (defun clearcase-vprop-read-activities-synchronously (viewtag)
4266 ;;   "Return a list of (activity-name . title) pairs for VIEWTAG"
4267 ;;   ;; nyi: ought to use a variant of clearcase-ct-blocking-call that returns a buffer
4268 ;;   ;;      rather than a string
4269
4270 ;;   ;; Performance: takes around 30 seconds to read 1000 activities.
4271 ;;   ;; Too slow to invoke willy-nilly on integration streams for example,
4272 ;;   ;; which typically can have 1000+ activities.
4273
4274 ;;   (let ((ret (clearcase-ct-blocking-call "lsact" "-view" viewtag)))
4275 ;;     (let ((buf (get-buffer-create "*clearcase-temp-activities*"))
4276 ;;           (activity-list nil))
4277 ;;       (save-excursion
4278 ;;         (set-buffer buf)
4279 ;;         (erase-buffer)
4280 ;;         (insert ret)
4281 ;;         (goto-char (point-min))
4282 ;;         ;; Slice out the 2nd and 4th fields as name and title
4283 ;;         ;;
4284 ;;         (while (re-search-forward "^[^ \t]+[ \t]+\\([^ \t]+\\)[ \t]+[^ \t]+[ \t]+\"+\\(.*\\)\"$" nil t)
4285 ;;           (setq activity-list (cons (cons (buffer-substring (match-beginning 1)
4286 ;;                                                             (match-end 1))
4287 ;;                                           (buffer-substring (match-beginning 2)
4288 ;;                                                             (match-end 2)))
4289 ;;                                     activity-list)))
4290 ;;         (kill-buffer buf))
4291
4292 ;;       ;; We've got activity-list in the reverse order that
4293 ;;       ;; cleartool+lsactivity generated them.  I think this is reverse
4294 ;;       ;; chronological order, so keep this order since it is more
4295 ;;       ;; convenient when setting to an activity.
4296 ;;       ;;
4297 ;;       ;;(nreverse activity-list))))
4298 ;;       activity-list)))
4299
4300 ;;}}}
4301
4302 ;;}}}
4303
4304 ;;{{{ Determining if a checkout was modified.
4305
4306 ;; How to tell if a file changed since checkout ?
4307 ;;
4308 ;; In the worst case we actually run "ct diff -pred" but we attempt several
4309 ;; less expensive tests first.
4310 ;;
4311 ;;  1. If it's size differs from pred.
4312 ;;  2. The mtime and the ctime are no longer the same.
4313 ;;
4314 ;; nyi: Other cheaper tests we could use:
4315 ;;
4316 ;;  (a) After each Emacs-driven checkout go and immediately fetch the mtime of
4317 ;;      the file and store as fprop-checkout-mtime. Then use that to compare
4318 ;;      against current mtime. This at least would make this function work
4319 ;;      right on files checked out by the current Emacs process.
4320 ;;
4321 ;;  (b) In the MVFS, after each Emacs-driven checkout go and immediately fetch
4322 ;;      the OID and store as fprop-checkout-oid. Then use that to compare
4323 ;;      against the current oid (the MVFS assigns a new OID at each write).
4324 ;;      This might not always be a win since we'd still need to run cleartool
4325 ;;      to get the current OID.
4326
4327 (defun clearcase-file-appears-modified-since-checkout-p (file)
4328   "Return whether FILE appears to have been modified since checkout.
4329 It doesn't examine the file contents."
4330
4331   (if (not (clearcase-fprop-checked-out file))
4332       nil
4333
4334     (let ((mvfs (clearcase-file-is-in-mvfs-p file)))
4335
4336       ;; We consider various cases in order of increasing cost to compute.
4337
4338       (cond
4339        ;; Case 1: (MVFS only) the size is different to its predecessor.
4340        ;;
4341        ((and mvfs
4342              (not
4343               (equal
4344                (clearcase-utl-file-size file)
4345                ;; nyi: For the snapshot case it'd be nice to get the size of the
4346                ;;      predecessor by using "ct+desc -pred -fmt" but there doesn't
4347                ;;      seem to be a format descriptor for file size. On the other hand
4348                ;;      ct+dump can obtain the size.
4349                ;;
4350                (clearcase-utl-file-size (clearcase-vxpath-cons-vxpath
4351                                          file
4352                                          (clearcase-fprop-predecessor-version
4353                                           file)))))
4354              ;; Return:
4355              ;;
4356              'size-changed))
4357
4358        ;; Case 2: (MVFS only) the mtime and the ctime are no longer the same.
4359        ;;
4360        ;; nyi: At least on Windows there seems to be a small number of seconds
4361        ;;      difference here even when the file is not modified.
4362        ;;      So we really check to see of they are close.
4363        ;;
4364        ;; nyi: This doesn't work in a snapshot view.
4365        ;;
4366        ((and mvfs
4367              (not (clearcase-utl-filetimes-close (clearcase-utl-file-mtime file)
4368                                                  (clearcase-utl-file-ctime file)
4369                                                  5))
4370              ;; Return:
4371              ;;
4372              'ctime-mtime-not-close))
4373
4374        (t
4375         ;; Case 3: last resort. Actually run a diff against predecessor.
4376         ;;
4377         (let ((ret (clearcase-ct-blocking-call "diff"
4378                                                "-options"
4379                                                "-quiet"
4380                                                "-pred"
4381                                                file)))
4382           (if (not (zerop (length ret)))
4383               ;; Return:
4384               ;;
4385               'diffs-nonempty
4386
4387             ;; Return:
4388             ;;
4389             nil)))))))
4390
4391 ;;}}}
4392
4393 ;;{{{ Tests for view-residency
4394
4395 ;;{{{ Tests for MVFS file residency
4396
4397 ;; nyi: probably superseded by clearcase-file-would-be-in-view-p
4398 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4399
4400 ;; nyi: this should get at least partially invalidated when
4401 ;;          VOBs are unmounted.
4402
4403 ;; nyi: make this different for NT
4404 ;;
4405 (defvar clearcase-always-mvfs-regexp (if (not clearcase-on-mswindows)
4406                                          "^/vobs/[^/]+/"
4407
4408                                        ;; nyi: express this using drive variable
4409                                        ;;
4410                                        (concat "^"
4411                                                "[Mm]:"
4412                                                clearcase-pname-sep-regexp)))
4413
4414 ;; This prevents the clearcase-file-vob-root function from pausing for long periods
4415 ;; stat-ing /net/host@@
4416 ;;
4417 ;; nyi: is there something equivalent on NT I need to avoid ?
4418 ;;
4419
4420 (defvar clearcase-never-mvfs-regexps (if clearcase-on-mswindows
4421                                          nil
4422                                        '(
4423                                          "^/net/[^/]+/"
4424                                          "^/tmp_mnt/net/[^/]+/"
4425                                          ))
4426   "Regexps matching those paths we can assume are never inside the MVFS.")
4427
4428 (defvar clearcase-known-vob-root-cache nil)
4429
4430 (defun clearcase-file-would-be-in-mvfs-p (filename)
4431   "Return whether FILE, after it is created, would reside in an MVFS filesystem."
4432   (let ((truename (file-truename filename)))
4433     (if (file-exists-p truename)
4434         (clearcase-file-is-in-mvfs-p truename)
4435       (let ((containing-dir (file-name-as-directory (file-name-directory truename))))
4436         (clearcase-file-is-in-mvfs-p containing-dir)))))
4437
4438 (defun clearcase-file-is-in-mvfs-p (filename)
4439   "Return whether existing FILE, resides in an MVFS filesystem."
4440   (let ((truename (file-truename filename)))
4441
4442     (or
4443      ;; case 1: its prefix matches an "always VOB" prefix like /vobs/...
4444      ;;
4445      ;; nyi: problem here: we return true for "/vobs/nonexistent/"
4446      ;;
4447      (numberp (string-match clearcase-always-mvfs-regexp truename))
4448
4449      ;; case 2: it has a prefix which is a known VOB-root
4450      ;;
4451      (clearcase-file-matches-vob-root truename clearcase-known-vob-root-cache)
4452
4453      ;; case 3: it has an ancestor dir which is a newly met VOB-root
4454      ;;
4455      (clearcase-file-vob-root truename))))
4456
4457 (defun clearcase-wd-is-in-mvfs ()
4458   "Return whether the current directory resides in an MVFS filesystem."
4459   (clearcase-file-is-in-mvfs-p (file-truename ".")))
4460
4461 (defun clearcase-file-matches-vob-root (truename vob-root-list)
4462   "Return whether TRUENAME has a prefix in VOB-ROOT-LIST."
4463   (if (null vob-root-list)
4464       nil
4465     (or (numberp (string-match (regexp-quote (car vob-root-list))
4466                                truename))
4467         (clearcase-file-matches-vob-root truename (cdr vob-root-list)))))
4468
4469 (defun clearcase-file-vob-root (truename)
4470   "File the highest versioned directory in TRUENAME."
4471
4472   ;; Use known non-MVFS patterns to rule some paths out.
4473   ;;
4474   (if (apply (function clearcase-utl-or-func)
4475              (mapcar (function (lambda (regexp)
4476                                  (string-match regexp truename)))
4477                      clearcase-never-mvfs-regexps))
4478       nil
4479     (let ((previous-dir nil)
4480           (dir  (file-name-as-directory (file-name-directory truename)))
4481           (highest-versioned-directory nil))
4482
4483       (while (not (string-equal dir previous-dir))
4484         (if (clearcase-file-covers-element-p dir)
4485             (setq highest-versioned-directory dir))
4486         (setq previous-dir dir)
4487         (setq dir (file-name-directory (directory-file-name dir))))
4488
4489       (if highest-versioned-directory
4490           (add-to-list 'clearcase-known-vob-root-cache highest-versioned-directory))
4491
4492       highest-versioned-directory)))
4493
4494 ;; Note: you should probably be using clearcase-fprop-mtype instead of this
4495 ;;       unless you really know what you're doing (nyi: check usages of this.)
4496 ;;
4497 (defun clearcase-file-covers-element-p (path)
4498   "Determine quickly if PATH refers to a Clearcase element,
4499 without caching the result."
4500
4501   ;; nyi: Even faster: consult the fprop cache first ?
4502
4503   (let ((element-dir (concat (clearcase-vxpath-element-part path) clearcase-vxpath-glue)))
4504     (and (file-exists-p path)
4505          (file-directory-p element-dir))))
4506
4507 ;;}}}
4508
4509 ;;{{{ Tests for snapshot view residency
4510
4511 ;; nyi: probably superseded by clearcase-file-would-be-in-view-p
4512 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4513
4514 (defvar clearcase-known-snapshot-root-cache nil)
4515
4516 (defun clearcase-file-would-be-in-snapshot-p (filename)
4517   "Return whether FILE, after it is created, would reside in a snapshot view.
4518 If so, return the viewtag."
4519   (let ((truename (file-truename filename)))
4520     (if (file-exists-p truename)
4521         (clearcase-file-is-in-snapshot-p truename)
4522       (let ((containing-dir (file-name-as-directory (file-name-directory truename))))
4523         (clearcase-file-is-in-snapshot-p containing-dir)))))
4524
4525 (defun clearcase-file-is-in-snapshot-p (truename)
4526   "Return whether existing FILE, resides in a snapshot view.
4527 If so, return the viewtag."
4528
4529   (or
4530    ;; case 1: it has a prefix which is a known snapshot-root
4531    ;;
4532    (clearcase-file-matches-snapshot-root truename clearcase-known-snapshot-root-cache)
4533
4534    ;; case 2: it has an ancestor dir which is a newly met VOB-root
4535    ;;
4536    (clearcase-file-snapshot-root truename)))
4537
4538 (defun clearcase-wd-is-in-snapshot ()
4539   "Return whether the current directory resides in a snapshot view."
4540   (clearcase-file-is-in-snapshot-p (file-truename ".")))
4541
4542 (defun clearcase-file-matches-snapshot-root (truename snapshot-root-list)
4543   "Return whether TRUENAME has a prefix in SNAPSHOT-ROOT-LIST."
4544   (if (null snapshot-root-list)
4545       nil
4546     (or (numberp (string-match (regexp-quote (car snapshot-root-list))
4547                                truename))
4548         (clearcase-file-matches-snapshot-root truename (cdr snapshot-root-list)))))
4549
4550 ;; This prevents the clearcase-file-snapshot-root function from pausing for long periods
4551 ;; stat-ing /net/host@@
4552 ;;
4553 ;; nyi: is there something equivalent on NT I need to avoid ?
4554 ;;
4555
4556 (defvar clearcase-never-snapshot-regexps (if clearcase-on-mswindows
4557                                              nil
4558                                            '(
4559                                              "^/net/[^/]+/"
4560                                              "^/tmp_mnt/net/[^/]+/"
4561                                              ))
4562   "Regexps matching those paths we can assume are never inside a snapshot view.")
4563
4564 (defun clearcase-file-snapshot-root (truename)
4565   "File the the snapshot view root containing TRUENAME."
4566
4567   ;; Use known non-snapshot patterns to rule some paths out.
4568   ;;
4569   (if (apply (function clearcase-utl-or-func)
4570              (mapcar (function (lambda (regexp)
4571                                  (string-match regexp truename)))
4572                      clearcase-never-snapshot-regexps))
4573       nil
4574     (let ((previous-dir nil)
4575           (dir (file-name-as-directory (file-name-directory truename)))
4576           (viewtag nil)
4577           (viewroot nil))
4578
4579
4580       (while (and (not (string-equal dir previous-dir))
4581                   (null viewtag))
4582
4583         ;; See if .view.dat exists and contains a valid view uuid
4584         ;;
4585         (let ((view-dat-name (concat dir (if clearcase-on-mswindows
4586                                              "view.dat" ".view.dat"))))
4587           (if (file-readable-p view-dat-name)
4588               (let ((uuid (clearcase-viewdat-to-uuid view-dat-name)))
4589                 (if uuid
4590                     (progn
4591                       (setq viewtag (clearcase-view-uuid-to-tag uuid))
4592                       (if viewtag
4593                           (setq viewroot dir)))))))
4594
4595         (setq previous-dir dir)
4596         (setq dir (file-name-directory (directory-file-name dir))))
4597
4598       (if viewroot
4599           (add-to-list 'clearcase-known-snapshot-root-cache viewroot))
4600
4601       ;; nyi: update a viewtag==>viewroot map ?
4602
4603       viewroot)))
4604
4605 (defun clearcase-viewdat-to-uuid (file)
4606   "Extract the view-uuid from a .view.dat file."
4607   ;; nyi, but return non-nil so clearcase-file-snapshot-root works
4608   t
4609   )
4610
4611 (defun clearcase-view-uuid-to-tag (uuid)
4612   "Look up the view-uuid in the register to discover its tag."
4613   ;; nyi, but return non-nil so clearcase-file-snapshot-root works
4614   t
4615   )
4616
4617 ;;}}}
4618
4619 ;; This is simple-minded but seems to work because cleartool+describe
4620 ;; groks snapshot views.
4621 ;;
4622 ;; nyi: Might be wise to cache view-roots to speed this up because the
4623 ;;      filename-handlers call this.
4624 ;;
4625 ;; nyi: Some possible shortcuts
4626 ;;      1. viewroot-relative path [syntax]
4627 ;;      2. under m:/ on NT        [syntax]
4628 ;;      3. setviewed on Unix      [find a containing VOB-root]
4629 ;;      4. subst-ed view on NT (calling net use seems very slow though)
4630 ;;                                [find a containing VOB-root]
4631 ;;      5. snapshot view
4632 ;;
4633 (defun clearcase-file-would-be-in-view-p (filename)
4634   "Return whether FILE, after it is created, would reside in a ClearCase view."
4635   (let  ((truename (file-truename (expand-file-name filename))))
4636
4637     ;; We use clearcase-path-file-really-exists-p here to make sure we are dealing
4638     ;; with a real file and not something faked by Emacs' file name handlers
4639     ;; like Ange-FTP.
4640     ;;
4641     (if (clearcase-path-file-really-exists-p truename)
4642         (clearcase-file-is-in-view-p truename)
4643       (let ((containing-dir (file-name-as-directory (file-name-directory truename))))
4644         (and (clearcase-path-file-really-exists-p containing-dir)
4645              (clearcase-file-is-in-view-p containing-dir))))))
4646
4647 (defun clearcase-file-is-in-view-p (filename)
4648   (let  ((truename (file-truename (expand-file-name filename))))
4649     ;; Shortcut if the file is a version-extended path.
4650     ;;
4651     (or (clearcase-file-snapshot-root truename)
4652         (clearcase-vxpath-p truename)
4653         (clearcase-fprop-mtype truename)
4654
4655         ;; nyi: How to efficiently know if we're in a dynamic-view root
4656         ;;   1. Test each contained name for elementness.
4657         ;;      Too inefficient.
4658         ;;   2. If it is viewroot-relative.
4659         ;;      Okay but not sufficient.
4660         ;;      How about case v:/ when view is substed ?
4661         ;;   3. We're setviewed.
4662         ;;      Okay but not sufficient.
4663         ;;  Maintain a cache of viewroots ?
4664         )))
4665
4666 (defun clearcase-file-viewtag (filename)
4667   "Find the viewtag associated with existing FILENAME."
4668
4669   (clearcase-when-debugging
4670    (assert (file-exists-p filename)))
4671
4672   (let ((truename (file-truename (expand-file-name filename))))
4673     (cond
4674
4675      ;; Case 1: viewroot-relative path
4676      ;;         ==> syntax
4677      ;;
4678      ((clearcase-vrpath-p truename)
4679       (clearcase-vrpath-viewtag truename))
4680
4681      ;; Case 2: under m:/ on NT
4682      ;;         ==> syntax
4683      ;;
4684      ((and clearcase-on-mswindows
4685            (string-match (concat clearcase-viewroot-drive
4686                                  clearcase-pname-sep-regexp
4687                                  "\\("
4688                                  clearcase-non-pname-sep-regexp "*"
4689                                  "\\)"
4690                                  )
4691                          truename))
4692       (substring truename (match-beginning 1) (match-end 1)))
4693
4694      ;; Case 3: setviewed on Unix
4695      ;;         ==> read EV, but need to check it's beneath a VOB-root
4696      ;;
4697      ((and clearcase-setview-viewtag
4698            (clearcase-file-would-be-in-mvfs-p truename))
4699       clearcase-setview-viewtag)
4700
4701      ;; Case 4: subst-ed view on NT
4702      ;;         ==> use ct+pwv -wdview
4703      ;; Case 5: snapshot view
4704      ;;         ==> use ct+pwv -wdview
4705      (t
4706       (clearcase-file-wdview truename)))))
4707
4708 (defun clearcase-file-wdview (truename)
4709   "Return the working-directory view associated with TRUENAME,
4710 or nil if none"
4711   (let ((default-directory (if (file-directory-p truename)
4712                                truename
4713                              (file-name-directory truename))))
4714     (clearcase-ct-cd default-directory)
4715     (let ((ret (clearcase-ct-blocking-call "pwv" "-wdview" "-short")))
4716       (if (not (string-match " NONE " ret))
4717           (clearcase-utl-1st-line-of-string ret)))))
4718
4719 ;;}}}
4720
4721 ;;{{{ The cleartool sub-process
4722
4723 ;; We use pipes rather than pty's for two reasons:
4724 ;;
4725 ;;   1. NT only has pipes
4726 ;;   2. On Solaris there appeared to be a problem in the pty handling part
4727 ;;      of Emacs, which resulted in Emacs/tq seeing too many cleartool prompt
4728 ;;      strings. This would occasionally occur and prevent the tq-managed
4729 ;;      interactions with the cleartool sub-process from working correctly.
4730 ;;
4731 ;; Now we use pipes. Cleartool detects the "non-tty" nature of the output
4732 ;; device and doesn't send a prompt. We manufacture an end-of-transaction
4733 ;; marker by sending a "pwd -h" after each cleartool sub-command and then use
4734 ;; the expected output of "Usage: pwd\n" as our end-of-txn pattern for tq.
4735 ;;
4736 ;; Even using pipes, the semi-permanent outboard-process using tq doesn't work
4737 ;; well on NT. There appear to be bugs in accept-process-output such that:
4738 ;;   0. there apparently were hairy race conditions, which a sprinkling
4739 ;;      of (accept-process-output nil 1) seemed to avoid somewhat.
4740 ;;   1. it never seems to timeout if you name a process as arg1.
4741 ;;   2. it always seems to wait for TIMEOUT, even if there is output ready.
4742 ;; The result seemed to be less responsive tha just calling a fresh cleartool
4743 ;; process for each invocation of clearcase-ct-blocking-call
4744 ;;
4745 ;; It still seems worthwhile to make it work on NT, as clearcase-ct-blocking-call
4746 ;; typically takes about 0.5 secs on NT versus 0.05 sec on Solaris,
4747 ;; an order of magnitude difference.
4748 ;;
4749
4750 (defconst clearcase-ct-eotxn-cmd "pwd -h\n")
4751 (defconst clearcase-ct-eotxn-response "Usage: pwd\n")
4752 (defconst clearcase-ct-eotxn-response-length (length clearcase-ct-eotxn-response))
4753
4754 (defconst clearcase-ct-subproc-timeout 30
4755   "Timeout on calls to subprocess")
4756
4757 (defvar clearcase-ct-tq nil
4758   "Transaction queue to talk to ClearTool in a subprocess")
4759
4760 (defvar clearcase-ct-return nil
4761   "Return value when we're involved in a blocking call")
4762
4763 (defvar clearcase-ct-view ""
4764   "Current view of cleartool subprocess, or the empty string if none")
4765
4766 (defvar clearcase-ct-wdir ""
4767   "Current working directory of cleartool subprocess,
4768 or the empty string if none")
4769
4770 (defvar clearcase-ct-running nil)
4771
4772 (defun clearcase-ct-accept-process-output (proc timeout)
4773   (accept-process-output proc timeout))
4774
4775 (defun clearcase-ct-start-cleartool ()
4776   (interactive)
4777   (clearcase-trace "clearcase-ct-start-cleartool()")
4778   (let ((process-environment (append '("ATRIA_NO_BOLD=1"
4779                                        "ATRIA_FORCE_GUI=1")
4780                                      ;;; emacs is a GUI, right? :-)
4781                                      process-environment)))
4782     (clearcase-trace (format "Starting cleartool in %s" default-directory))
4783     (let* ( ;; Force the use of a pipe
4784            ;;
4785            (process-connection-type nil)
4786            (cleartool-process
4787             (start-process "cleartool" ;; Absolute path won't work here
4788                            " *cleartool*"
4789                            clearcase-cleartool-path)))
4790       (process-kill-without-query cleartool-process)
4791       (setq clearcase-ct-view "")
4792       (setq clearcase-ct-tq (tq-create cleartool-process))
4793       (tq-enqueue clearcase-ct-tq
4794                   clearcase-ct-eotxn-cmd ;; question
4795                   clearcase-ct-eotxn-response ;; regexp
4796                   'clearcase-ct-running ;; closure
4797                   'set) ;; function
4798       (while (not clearcase-ct-running)
4799         (message "waiting for cleartool to start...")
4800         (clearcase-ct-accept-process-output (tq-process clearcase-ct-tq)
4801                                             clearcase-ct-subproc-timeout))
4802       ;; Assign a sentinel to restart it if it dies.
4803       ;; nyi: This needs debugging.
4804       ;;(set-process-sentinel cleartool-process 'clearcase-ct-sentinel)
4805
4806       (clearcase-trace "clearcase-ct-start-cleartool() done")
4807       (message "waiting for cleartool to start...done"))))
4808
4809 ;; nyi: needs debugging.
4810 ;;
4811 (defun clearcase-ct-sentinel (process event-string)
4812   (clearcase-trace (format "Cleartool process sentinel called: %s" event-string))
4813   (if (not (eq 'run (process-status process)))
4814       (progn
4815         ;; Restart the dead cleartool.
4816         ;;
4817         (clearcase-trace "Cleartool process restarted")
4818         (clearcase-ct-start-cleartool))))
4819
4820 (defun clearcase-ct-kill-cleartool ()
4821   "Kill off cleartool subprocess.  If another one is needed,
4822 it will be restarted.  This may be useful if you're debugging clearcase."
4823   (interactive)
4824   (clearcase-ct-kill-tq))
4825
4826 (defun clearcase-ct-callback (arg val)
4827   (clearcase-trace (format "clearcase-ct-callback:<\n"))
4828   (clearcase-trace val)
4829   (clearcase-trace (format "clearcase-ct-callback:>\n"))
4830   ;; This can only get called when the last thing received from
4831   ;; the cleartool sub-process was clearcase-ct-eotxn-response,
4832   ;; so it is safe to just remove it here.
4833   ;;
4834   (setq clearcase-ct-return (substring val 0 (- clearcase-ct-eotxn-response-length))))
4835
4836 (defun clearcase-ct-do-cleartool-command (command file comment &optional extra-args)
4837   "Execute a cleartool command, notifying user and checking for
4838 errors. Output from COMMAND goes to buffer *clearcase*.  The last argument of the
4839 command is the name of FILE; this is appended to an optional list of
4840 EXTRA-ARGS."
4841
4842   (if file
4843       (setq file (expand-file-name file)))
4844   (if (listp command)
4845       (error "command must not be a list"))
4846   (if clearcase-command-messages
4847       (if file
4848           (message "Running %s on %s..." command file)
4849         (message "Running %s..." command)))
4850   (let ((camefrom (current-buffer))
4851         (squeezed nil)
4852         status)
4853     (set-buffer (get-buffer-create "*clearcase*"))
4854     (setq buffer-read-only nil)
4855     (erase-buffer)
4856     (set (make-local-variable 'clearcase-parent-buffer) camefrom)
4857     (set (make-local-variable 'clearcase-parent-buffer-name)
4858          (concat " from " (buffer-name camefrom)))
4859
4860     ;; This is so that command arguments typed in the *clearcase* buffer will
4861     ;; have reasonable defaults.
4862     ;;
4863     (if file
4864         (setq default-directory (file-name-directory file)))
4865
4866     (mapcar
4867      (function (lambda (s)
4868                  (and s
4869                       (not (zerop (length s)))
4870                       (setq squeezed
4871                             (append squeezed (list s))))))
4872      extra-args)
4873
4874     (clearcase-with-tempfile
4875      comment-file
4876      (if (not (eq comment 'unused))
4877          (if comment
4878              (progn
4879                (write-region comment nil comment-file nil 'noprint)
4880                (setq squeezed (append squeezed (list "-cfile" (clearcase-path-native comment-file)))))
4881            (setq squeezed (append squeezed (list "-nc")))))
4882      (if file
4883          (setq squeezed (append squeezed (list (clearcase-path-native file)))))
4884      (let ((default-directory (file-name-directory
4885                                (or file default-directory))))
4886        (clearcase-ct-cd default-directory)
4887        (if clearcase-command-messages
4888            (message "Running %s..." command))
4889        (insert
4890         (apply 'clearcase-ct-cleartool-cmd (append (list command) squeezed)))
4891        (if clearcase-command-messages
4892            (message "Running %s...done" command))))
4893
4894     (goto-char (point-min))
4895     (clearcase-view-mode 0 camefrom)
4896     (set-buffer-modified-p nil)         ; XEmacs - fsf uses `not-modified'
4897     (if (re-search-forward "^cleartool: Error:.*$" nil t)
4898         (progn
4899           (setq status (buffer-substring (match-beginning 0) (match-end 0)))
4900           (clearcase-port-view-buffer-other-window "*clearcase*")
4901           (shrink-window-if-larger-than-buffer)
4902           (error "Running %s...FAILED (%s)" command status))
4903       (if clearcase-command-messages
4904           (message "Running %s...OK" command)))
4905     (set-buffer camefrom)
4906     status))
4907
4908 (defun clearcase-ct-cd (dir)
4909   (if (or (not dir)
4910           (string= dir clearcase-ct-wdir))
4911       clearcase-ct-wdir
4912     (clearcase-ct-blocking-call "cd" (clearcase-path-native dir))
4913     (setq clearcase-ct-wdir dir)))
4914
4915 (defun clearcase-ct-cleartool-cmd (&rest cmd)
4916   (apply 'clearcase-ct-blocking-call cmd))
4917
4918 ;; NT Emacs - needs a replacement for tq.
4919 ;;
4920 (defun clearcase-ct-get-command-stdout (program &rest args)
4921   "Call PROGRAM.
4922 Returns PROGRAM's stdout.
4923 ARGS is the command line arguments to PROGRAM."
4924   (let ((buf (get-buffer-create "cleartoolexecution")))
4925     (prog1
4926         (save-excursion
4927           (set-buffer buf)
4928           (apply 'call-process program nil buf nil args)
4929           (buffer-string))
4930       (kill-buffer buf))))
4931
4932 ;; The TQ interaction still doesn't work on NT.
4933 ;;
4934 (defvar clearcase-disable-tq clearcase-on-mswindows
4935   "Set to T if the Emacs/cleartool interactions via tq are not working right.")
4936
4937 (defun clearcase-ct-blocking-call (&rest cmd)
4938   (clearcase-trace (format "clearcase-ct-blocking-call(%s)" cmd))
4939   (save-excursion
4940     (setq clearcase-ct-return nil)
4941
4942     (if clearcase-disable-tq
4943         ;; Don't use tq:
4944         ;;
4945         (setq clearcase-ct-return (apply 'clearcase-ct-get-command-stdout
4946                                          clearcase-cleartool-path cmd))
4947
4948       ;; Use tq:
4949       ;;
4950       (setq clearcase-ct-return nil)
4951       (if (not clearcase-ct-tq)
4952           (clearcase-ct-start-cleartool))
4953       (unwind-protect
4954           (let ((command ""))
4955             (mapcar
4956              (function
4957               (lambda (token)
4958                 ;; If the token has imbedded spaces and is not already quoted,
4959                 ;; add double quotes.
4960                 ;;
4961                 (setq command (concat command
4962                                       " "
4963                                       (clearcase-utl-quote-if-nec token)))))
4964              cmd)
4965             (tq-enqueue clearcase-ct-tq
4966                         (concat command "\n"
4967                                 clearcase-ct-eotxn-cmd) ;; question
4968                         clearcase-ct-eotxn-response ;; regexp
4969                         nil ;; closure
4970                         'clearcase-ct-callback) ;; function
4971             (while (not clearcase-ct-return)
4972               (clearcase-ct-accept-process-output (tq-process clearcase-ct-tq)
4973                                                   clearcase-ct-subproc-timeout)))
4974         ;; Error signalled:
4975         ;;
4976         (while (tq-queue clearcase-ct-tq)
4977           (tq-queue-pop clearcase-ct-tq)))))
4978   (if (string-match "cleartool: Error:" clearcase-ct-return)
4979       (error "cleartool process error %s: "
4980              (substring clearcase-ct-return (match-end 0))))
4981   (clearcase-trace (format "command-result(%s)" clearcase-ct-return))
4982   clearcase-ct-return)
4983
4984 (defun clearcase-ct-kill-tq ()
4985   (setq clearcase-ct-running nil)
4986   (setq clearcase-ct-tq nil)
4987   (process-send-eof (tq-process clearcase-ct-tq))
4988   (kill-process (tq-process clearcase-ct-tq)))
4989
4990 (defun clearcase-ct-kill-buffer-hook ()
4991
4992   ;; NT Emacs - doesn't use tq.
4993   ;;
4994   (if (not clearcase-on-mswindows)
4995       (let ((kill-buffer-hook nil))
4996         (if (and (boundp 'clearcase-ct-tq)
4997                  clearcase-ct-tq
4998                  (eq (current-buffer) (tq-buffer clearcase-ct-tq)))
4999             (error "Don't kill TQ buffer %s, use `clearcase-ct-kill-tq'" (current-buffer))))))
5000
5001 (add-hook 'kill-buffer-hook 'clearcase-ct-kill-buffer-hook)
5002
5003 ;;}}}
5004
5005 ;;{{{ Invoking a command
5006
5007 ;; nyi Would be redundant if we didn't need it to invoke normal-diff-program
5008
5009 (defun clearcase-do-command (okstatus command file &optional extra-args)
5010   "Execute a version-control command, notifying user and checking for errors.
5011 The command is successful if its exit status does not exceed OKSTATUS.
5012 Output from COMMAND goes to buffer *clearcase*.  The last argument of the command is
5013 an optional list of EXTRA-ARGS."
5014   (setq file (expand-file-name file))
5015   (if clearcase-command-messages
5016       (message "Running %s on %s..." command file))
5017   (let ((camefrom (current-buffer))
5018         (pwd )
5019         (squeezed nil)
5020         status)
5021     (set-buffer (get-buffer-create "*clearcase*"))
5022     (setq buffer-read-only nil)
5023     (erase-buffer)
5024     (set (make-local-variable 'clearcase-parent-buffer) camefrom)
5025     (set (make-local-variable 'clearcase-parent-buffer-name)
5026          (concat " from " (buffer-name camefrom)))
5027     ;; This is so that command arguments typed in the *clearcase* buffer will
5028     ;; have reasonable defaults.
5029     ;;
5030     (setq default-directory (file-name-directory file)
5031           file (file-name-nondirectory file))
5032
5033     (mapcar
5034      (function (lambda (s)
5035                  (and s
5036                       (not (zerop (length s)))
5037                       (setq squeezed
5038                             (append squeezed (list s))))))
5039      extra-args)
5040     (setq squeezed (append squeezed (list file)))
5041     (setq status (apply 'call-process command nil t nil squeezed))
5042     (goto-char (point-min))
5043     (clearcase-view-mode 0 camefrom)
5044     (set-buffer-modified-p nil)         ; XEmacs - fsf uses `not-modified'
5045     (if (or (not (integerp status)) (< okstatus status))
5046         (progn
5047           (clearcase-port-view-buffer-other-window "*clearcase*")
5048           (shrink-window-if-larger-than-buffer)
5049           (error "Running %s...FAILED (%s)" command
5050                  (if (integerp status)
5051                      (format "status %d" status)
5052                    status)))
5053       (if clearcase-command-messages
5054           (message "Running %s...OK" command)))
5055     (set-buffer camefrom)
5056     status))
5057
5058 ;;}}}
5059
5060 ;;{{{ Viewtag management
5061
5062 ;;{{{ Started views
5063
5064 (defun clearcase-viewtag-try-to-start-view (viewtag)
5065   "If VIEW is not apparently already visible under viewroot, start it."
5066   (if (not (member viewtag (clearcase-viewtag-started-viewtags)))
5067       (clearcase-viewtag-start-view viewtag)))
5068
5069 (defun clearcase-viewtag-started-viewtags-alist ()
5070   "Return an alist of views that are currently visible under the viewroot."
5071   (mapcar
5072    (function
5073     (lambda (tag)
5074       (list (concat tag "/"))))
5075    (clearcase-viewtag-started-viewtags)))
5076
5077 (defun clearcase-viewtag-started-viewtags ()
5078   "Return the list of viewtags already visible under the viewroot."
5079   (let ((raw-list  (if clearcase-on-mswindows
5080                        (directory-files clearcase-viewroot-drive)
5081                      (directory-files clearcase-viewroot))))
5082     (clearcase-utl-list-filter
5083      (function (lambda (string)
5084                  ;; Exclude the ones that start with ".",
5085                  ;; and the ones that end with "@@".
5086                  ;;
5087                  (and (not (equal ?. (aref string 0)))
5088                       (not (string-match "@@$" string)))))
5089      raw-list)))
5090
5091 ;; nyi: Makes sense on NT ?
5092 ;;      Probably also want to run subst ?
5093 ;;      Need a better high-level interface to start-view
5094 ;;
5095 (defun clearcase-viewtag-start-view (viewtag)
5096   "If VIEWTAG is in our cache of valid view names, start it."
5097   (if (clearcase-viewtag-exists viewtag)
5098       (progn
5099         (message "Starting view server for %s..." viewtag)
5100         (clearcase-ct-blocking-call "startview" viewtag)
5101         (message "Starting view server for %s...done" viewtag))))
5102
5103 ;;}}}
5104
5105 ;;{{{ All views
5106
5107 ;;{{{ Internals
5108
5109 (defvar clearcase-viewtag-cache nil
5110   "Oblist of all known viewtags.")
5111
5112 (defvar clearcase-viewtag-dir-cache nil
5113   "Oblist of all known viewtag dirs.")
5114
5115 (defvar clearcase-viewtag-cache-timeout 1800
5116   "*Default timeout of all-viewtag cache, in seconds.")
5117
5118 (defun clearcase-viewtag-schedule-cache-invalidation ()
5119   "Schedule the next invalidation of clearcase-viewtag-cache."
5120   (run-at-time (format "%s sec" clearcase-viewtag-cache-timeout)
5121                nil
5122                (function (lambda (&rest ignore)
5123                            (setq clearcase-viewtag-cache nil)))
5124                nil))
5125 ;; Some primes:
5126 ;;
5127 ;;     1,
5128 ;;     2,
5129 ;;     3,
5130 ;;     7,
5131 ;;     17,
5132 ;;     31,
5133 ;;     61,
5134 ;;     127,
5135 ;;     257,
5136 ;;     509,
5137 ;;     1021,
5138 ;;     2053,
5139
5140 (defun clearcase-viewtag-read-all-viewtags ()
5141   "Invoke ct+lsview to get all viewtags, and return an obarry containing them."
5142   (message "Fetching view names...")
5143   (let* ((default-directory "/")
5144          (result (make-vector 1021 0))
5145          (raw-views-string (clearcase-ct-blocking-call "lsview" "-short"))
5146          (view-list (clearcase-utl-split-string-at-char raw-views-string ?\n)))
5147     (message "Fetching view names...done")
5148     (mapcar (function (lambda (string)
5149                         (set (intern string result) t)))
5150             view-list)
5151     result))
5152
5153 (defun clearcase-viewtag-populate-caches ()
5154   (setq clearcase-viewtag-cache (clearcase-viewtag-read-all-viewtags))
5155   (let ((dir-cache (make-vector 1021 0)))
5156     (mapatoms
5157      (function (lambda (sym)
5158                  (set (intern (concat (symbol-name sym) "/") dir-cache) t)))
5159      clearcase-viewtag-cache)
5160     (setq clearcase-viewtag-dir-cache dir-cache))
5161   (clearcase-viewtag-schedule-cache-invalidation))
5162
5163 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
5164
5165 ;;}}}
5166
5167 ;; Exported interfaces
5168
5169 ;; This is for completion of viewtags.
5170 ;;
5171 (defun clearcase-viewtag-all-viewtags-obarray ()
5172   "Return an obarray of all valid viewtags as of the last time we looke  d."
5173   (if (null clearcase-viewtag-cache)
5174       (clearcase-viewtag-populate-caches))
5175   clearcase-viewtag-cache)
5176
5177 ;; This is for completion of viewtag dirs, like /view/my_view_name/
5178 ;; The trailing slash is required for compatibility with other instances
5179 ;; of filename completion in Emacs.
5180 ;;
5181 (defun clearcase-viewtag-all-viewtag-dirs-obarray ()
5182   "Return an obarray of all valid viewtag directory names as of the last time we looked."
5183   (if (null clearcase-viewtag-dir-cache)
5184       (clearcase-viewtag-populate-caches))
5185   clearcase-viewtag-dir-cache)
5186
5187 (defun clearcase-viewtag-exists (viewtag)
5188   (symbol-value (intern-soft viewtag (clearcase-viewtag-all-viewtags-obarray))))
5189
5190 ;;}}}
5191
5192 ;;}}}
5193
5194 ;;{{{ Pathnames
5195
5196 ;;{{{ Pathnames: version-extended
5197
5198 (defun clearcase-vxpath-p (path)
5199   (or (string-match (concat clearcase-vxpath-glue "/") path)
5200       (string-match (concat clearcase-vxpath-glue "\\\\") path)))
5201
5202 (defun clearcase-vxpath-element-part (vxpath)
5203   "Return the element part of version-extended PATH."
5204   (if (string-match clearcase-vxpath-glue vxpath)
5205       (substring vxpath 0 (match-beginning 0))
5206     vxpath))
5207
5208 (defun clearcase-vxpath-version-part (vxpath)
5209   "Return the version part of version-extended PATH."
5210   (if (string-match clearcase-vxpath-glue vxpath)
5211       (substring vxpath (match-end 0))
5212     nil))
5213
5214 (defun clearcase-vxpath-branch (vxpath)
5215   "Return the branch part of a version-extended path or of a version"
5216   (if (clearcase-vxpath-p vxpath)
5217       (clearcase-vxpath-cons-vxpath
5218        (clearcase-vxpath-element-part vxpath)
5219        (file-name-directory (clearcase-vxpath-version-part vxpath)))
5220     (file-name-directory vxpath)))
5221
5222 (defun clearcase-vxpath-version (vxpath)
5223   "Return the numeric version part of a version-extended path or of a version"
5224   (if (clearcase-vxpath-p vxpath)
5225       (file-name-nondirectory (clearcase-vxpath-version-part vxpath))
5226     (file-name-nondirectory vxpath)))
5227
5228 (defun clearcase-vxpath-cons-vxpath (file version &optional viewtag)
5229   "Make a ClearCase version-extended pathname for ELEMENT's version VERSION.
5230 If ELEMENT is actually a version-extended pathname, substitute VERSION for
5231 the version included in ELEMENT.  If VERSION is nil, remove the version-extended
5232 pathname.
5233
5234 If optional VIEWTAG is specified, make a view-relative pathname, possibly
5235 replacing the existing view prefix."
5236   (let* ((element (clearcase-vxpath-element-part file))
5237          (glue-fmt (if (and (> (length version) 0)
5238                             (= (aref version 0) ?/))
5239                        (concat "%s" clearcase-vxpath-glue "%s")
5240                      (concat "%s" clearcase-vxpath-glue "/%s")))
5241          (relpath (clearcase-vrpath-tail element)))
5242     (if viewtag
5243         (setq element (concat clearcase-viewroot "/" viewtag (or relpath element))))
5244     (if version
5245         (format glue-fmt element version)
5246       element)))
5247
5248 ;; NYI: This should cache the predecessor version as a property
5249 ;; of the file.
5250 ;;
5251 (defun clearcase-vxpath-of-predecessor (file)
5252   "Compute the version-extended pathname of the predecessor version of FILE."
5253   (if (not (equal 'version (clearcase-fprop-mtype file)))
5254       (error "Not a clearcase version: %s" file))
5255   (let ((abs-file (expand-file-name file)))
5256     (let ((ver (clearcase-utl-1st-line-of-string
5257                 (clearcase-ct-cleartool-cmd "describe"
5258                                             "-pred"
5259                                             "-short"
5260                                             (clearcase-path-native abs-file)))))
5261       (clearcase-path-canonicalise-slashes (concat
5262                                             (clearcase-vxpath-element-part file)
5263                                             clearcase-vxpath-glue
5264                                             ver)))))
5265
5266 (defun clearcase-vxpath-version-extend (file)
5267   "Compute the version-extended pathname of FILE."
5268   (if (not (equal 'version (clearcase-fprop-mtype file)))
5269       (error "Not a clearcase version: %s" file))
5270   (let ((abs-file (expand-file-name file)))
5271     (clearcase-path-canonicalise-slashes
5272      (clearcase-utl-1st-line-of-string
5273       (clearcase-ct-cleartool-cmd "describe"
5274                                   "-fmt"
5275                                   (concat "%En"
5276                                           clearcase-vxpath-glue
5277                                           "%Vn")
5278                                   (clearcase-path-native abs-file))))))
5279
5280 (defun clearcase-vxpath-of-branch-base (file)
5281   "Compute the version-extended pathname of the version at the branch base of FILE."
5282   (let* ((file-version-path
5283           (if  (clearcase-fprop-checked-out file)
5284               ;; If the file is checked-out, start with its predecessor version...
5285               ;;
5286               (clearcase-vxpath-version-extend (clearcase-vxpath-of-predecessor file))
5287             ;; ...otherwise start with the file's version.
5288             ;;
5289             (clearcase-vxpath-version-extend file)))
5290          (file-version-number (string-to-int (clearcase-vxpath-version file-version-path)))
5291          (branch (clearcase-vxpath-branch file-version-path)))
5292     (let* ((base-number 0)
5293            (base-version-path (format "%s%d" branch base-number)))
5294       (while (and (not (clearcase-file-is-in-snapshot-p base-version-path))
5295                   (not (file-exists-p base-version-path))
5296                   (< base-number file-version-number))
5297         (setq base-number (1+ base-number))
5298         (setq base-version-path (format "%s%d" branch base-number)))
5299       base-version-path)))
5300
5301 (defun clearcase-vxpath-version-of-branch-base (file)
5302   (clearcase-vxpath-version-part (clearcase-vxpath-of-branch-base file)))
5303
5304 (defun clearcase-vxpath-get-version-in-buffer (vxpath)
5305   "Return a buffer containing the version named by VXPATH.
5306 Intended for use in snapshot views."
5307   (let* ((temp-file (clearcase-vxpath-get-version-in-temp-file vxpath))
5308          (buffer (find-file-noselect temp-file t)))
5309
5310     ;; XEmacs throws an error if you delete a read-only file
5311     ;;
5312     (if clearcase-xemacs-p
5313         (if (not (file-writable-p temp-file))
5314             (set-file-modes temp-file (string-to-number "666" 8))))
5315
5316     (delete-file temp-file)
5317     buffer))
5318
5319 (defun clearcase-vxpath-get-version-in-temp-file (vxpath)
5320   "Return the name of a temporary file containing the version named by VXPATH.
5321 Intended for use in snapshot views."
5322
5323   (let ((temp-file (clearcase-utl-tempfile-name vxpath)))
5324     (progn
5325       (clearcase-ct-blocking-call "get"
5326                                   "-to"
5327                                   (clearcase-path-native temp-file)
5328                                   (clearcase-path-native vxpath))
5329       temp-file)))
5330
5331 ;;}}}
5332
5333 ;;{{{ Pathnames: viewroot-relative
5334
5335 ;; nyi: make all this work with viewroot-drive-relative files too
5336
5337 (defun clearcase-vrpath-p (path)
5338   "Return whether PATH is viewroot-relative."
5339   (string-match clearcase-vrpath-regexp path))
5340
5341 (defun clearcase-vrpath-head (vrpath)
5342   "Given viewroot-relative PATH, return the prefix including the view-tag."
5343   (if (string-match clearcase-vrpath-regexp vrpath)
5344       (substring vrpath (match-end 0))))
5345
5346 (defun clearcase-vrpath-tail (vrpath)
5347   "Given viewroot-relative PATH, return the suffix after the view-tag."
5348   (if (string-match clearcase-vrpath-regexp vrpath)
5349       (substring vrpath (match-end 0))))
5350
5351 (defun clearcase-vrpath-viewtag (vrpath)
5352   "Given viewroot-relative PATH, return the view-tag."
5353   (if (string-match clearcase-vrpath-regexp vrpath)
5354       (substring vrpath (match-beginning 1) (match-end 1))))
5355
5356 ;; Remove useless viewtags from a pathname.
5357 ;; e.g. if we're setviewed to view "VIEWTAG"
5358 ;;    (clearcase-path-remove-useless-viewtags "/view/VIEWTAG/PATH")
5359 ;;     ==> "PATH"
5360 ;;    (clearcase-path-remove-useless-viewtags "/view/z/view/y/PATH")
5361 ;;     ==> /view/y/"PATH"
5362 ;;
5363 (defvar clearcase-multiple-viewroot-regexp
5364   (concat "^"
5365           clearcase-viewroot
5366           clearcase-pname-sep-regexp
5367           clearcase-non-pname-sep-regexp "+"
5368           "\\("
5369           clearcase-viewroot
5370           clearcase-pname-sep-regexp
5371           "\\)"
5372           ))
5373
5374 (defun clearcase-path-remove-useless-viewtags (pathname)
5375   ;; Try to avoid file-name-handler recursion here:
5376   ;;
5377   (let ((setview-root clearcase-setview-root))
5378     (if setview-root
5379         ;; Append "/":
5380         ;;
5381         (setq setview-root (concat setview-root "/")))
5382
5383     (cond
5384
5385      ((string-match clearcase-multiple-viewroot-regexp pathname)
5386       (clearcase-path-remove-useless-viewtags (substring pathname (match-beginning 1))))
5387
5388      ((and setview-root
5389            (string= setview-root "/"))
5390       pathname)
5391
5392      ;; If pathname has setview-root as a proper prefix,
5393      ;; strip it off and recurse:
5394      ;;
5395      ((and setview-root
5396            (< (length setview-root) (length pathname))
5397            (string= setview-root (substring pathname 0 (length setview-root))))
5398       (clearcase-path-remove-useless-viewtags (substring pathname (- (length setview-root) 1))))
5399
5400      (t
5401       pathname))))
5402
5403 ;;}}}
5404
5405 ;; Don't pass the "INPLACE" parameter to subst-char-in-string here since the
5406 ;; parameter is not necessarily a local variable (in some cases it is
5407 ;; buffer-file-name and replacing / with \ in it wreaks havoc).
5408 ;;
5409 (defun clearcase-path-canonicalise-slashes (path)
5410   (if (not clearcase-on-mswindows)
5411       path
5412     (subst-char-in-string ?\\ ?/ path)))
5413
5414 (defun clearcase-path-canonical (path)
5415   (if (not clearcase-on-mswindows)
5416       path
5417     (if clearcase-on-cygwin
5418         (substring (shell-command-to-string (concat "cygpath -u '" path "'")) 0 -1)
5419       (subst-char-in-string ?\\ ?/ path))))
5420
5421 (defun clearcase-path-native (path)
5422   (if (not clearcase-on-mswindows)
5423       path
5424     (if clearcase-on-cygwin
5425         (substring (shell-command-to-string (concat "cygpath -w " path)) 0 -1)
5426       (subst-char-in-string ?/ ?\\ path))))
5427
5428 (defun clearcase-path-file-really-exists-p (filename)
5429   "Test if a file really exists, when all file-name handlers are disabled."
5430   (let ((inhibit-file-name-operation 'file-exists-p)
5431         (inhibit-file-name-handlers (mapcar
5432                                      (lambda (pair)
5433                                        (cdr pair))
5434                                      file-name-handler-alist)))
5435     (file-exists-p filename)))
5436
5437 (defun clearcase-path-file-in-any-scopes (file scopes)
5438   (let ((result nil)
5439         (cursor scopes))
5440     (while (and (null result)
5441                 cursor)
5442       (if (clearcase-path-file-in-scope file (car cursor))
5443           (setq result t))
5444       (setq cursor (cdr cursor)))
5445     result))
5446
5447
5448 (defun clearcase-path-file-in-scope (file scope)
5449   (assert (file-name-absolute-p file))
5450   (assert (file-name-absolute-p scope))
5451
5452   (or
5453    ;; Pathnames are equal
5454    ;;
5455    (string= file scope)
5456
5457    ;; scope-qua-dir is an ancestor of file (proper string prefix)
5458    ;;
5459    (let ((scope-as-dir (concat scope "/")))
5460      (string= scope-as-dir
5461               (substring file 0 (length scope-as-dir))))))
5462
5463 ;;}}}
5464
5465 ;;{{{ Mode-line
5466
5467 (defun clearcase-mode-line-buffer-id (filename)
5468   "Compute an abbreviated version string for the mode-line.
5469 It will be in one of three forms: /main/NNN, or .../branchname/NNN, or DO-NAME"
5470
5471   (if (clearcase-fprop-checked-out filename)
5472       (if (clearcase-fprop-reserved filename)
5473           "RESERVED"
5474         "UNRESERVED")
5475     (let ((ver-string (clearcase-fprop-version filename)))
5476       (if (not (zerop (length ver-string)))
5477           (let ((i (length ver-string))
5478                 (slash-count 0))
5479             ;; Search back from the end to the second-last slash
5480             ;;
5481             (while (and (> i 0)
5482                         (< slash-count  2))
5483               (if (equal ?/ (aref ver-string (1- i)))
5484                   (setq slash-count (1+ slash-count)))
5485               (setq i (1- i)))
5486             (if (> i 0)
5487                 (concat "..." (substring ver-string i))
5488               (substring ver-string i)))))))
5489
5490 ;;}}}
5491
5492 ;;{{{ Minibuffer reading
5493
5494 ;;{{{ clearcase-read-version-name
5495
5496 (defun clearcase-read-version-name (prompt file)
5497   "Display PROMPT and read a version string for FILE in the minibuffer,
5498 with completion if possible."
5499   (let* ((insert-default-directory nil)
5500          (predecessor (clearcase-fprop-predecessor-version file))
5501          (default-filename (clearcase-vxpath-cons-vxpath file predecessor))
5502
5503          ;; To get this to work it is necessary to make Emacs think
5504          ;; we're completing with respect to "ELEMENT@@/" rather
5505          ;; than "ELEMENT@@". Otherwise when we enter a version
5506          ;; like "/main/NN", it thinks we entered an absolute path.
5507          ;; So instead, we prompt the user to enter "main/..../NN"
5508          ;; and add back the leading slash before returning.
5509          ;;
5510          (completing-dir (concat file "@@/")))
5511     (if (and (clearcase-file-is-in-mvfs-p file) (not clearcase-on-mswindows))
5512         ;; Completion only works in MVFS:
5513         ;;
5514         (concat "/" (read-file-name prompt
5515                                     completing-dir
5516                                     (substring predecessor 1)
5517                                     ;;nil
5518                                     t
5519                                     (substring predecessor 1)))
5520       (concat "/" (read-string prompt
5521                                (substring predecessor 1)
5522                                nil)))))
5523
5524 ;;}}}
5525
5526 ;;{{{ clearcase-read-label-name
5527
5528 ;; nyi: unused
5529
5530 (defun clearcase-read-label-name (prompt)
5531   "Read a label name."
5532
5533   (let* ((string (clearcase-ct-cleartool-cmd "lstype"
5534                                              "-kind"
5535                                              "lbtype"
5536                                              "-short"))
5537          labels)
5538     (mapcar (function (lambda (arg)
5539                         (if (string-match "(locked)" arg)
5540                             nil
5541                           (setq labels (cons (list arg) labels)))))
5542             (clearcase-utl-split-string string "\n"))
5543     (completing-read prompt labels nil t)))
5544
5545 ;;}}}
5546
5547 ;;}}}
5548
5549 ;;{{{ Directory-tree walking
5550
5551 (defun clearcase-dir-all-files (func &rest args)
5552   "Invoke FUNC f ARGS on each regular file f in default directory."
5553   (let ((dir default-directory))
5554     (message "Scanning directory %s..." dir)
5555     (mapcar (function (lambda (f)
5556                         (let ((dirf (expand-file-name f dir)))
5557                           (apply func dirf args))))
5558             (directory-files dir))
5559     (message "Scanning directory %s...done" dir)))
5560
5561 (defun clearcase-file-tree-walk-internal (file func args quiet)
5562   (if (not (file-directory-p file))
5563       (apply func file args)
5564     (or quiet
5565         (message "Traversing directory %s..." file))
5566     (let ((dir (file-name-as-directory file)))
5567       (mapcar
5568        (function
5569         (lambda (f) (or
5570                      (string-equal f ".")
5571                      (string-equal f "..")
5572                      (member f clearcase-directory-exclusion-list)
5573                      (let ((dirf (concat dir f)))
5574                        (or
5575                         (file-symlink-p dirf) ;; Avoid possible loops
5576                         (clearcase-file-tree-walk-internal dirf func args quiet))))))
5577        (directory-files dir)))))
5578 ;;
5579 (defun clearcase-file-tree-walk (func &rest args)
5580   "Walk recursively through default directory.
5581 Invoke FUNC f ARGS on each non-directory file f underneath it."
5582   (clearcase-file-tree-walk-internal default-directory func args nil)
5583   (message "Traversing directory %s...done" default-directory))
5584
5585 (defun clearcase-subdir-tree-walk (func &rest args)
5586   "Walk recursively through default directory.
5587 Invoke FUNC f ARGS on each subdirectory underneath it."
5588   (clearcase-subdir-tree-walk-internal default-directory func args nil)
5589   (message "Traversing directory %s...done" default-directory))
5590
5591 (defun clearcase-subdir-tree-walk-internal (file func args quiet)
5592   (if (file-directory-p file)
5593       (let ((dir (file-name-as-directory file)))
5594         (apply func dir args)
5595         (or quiet
5596             (message "Traversing directory %s..." file))
5597         (mapcar
5598          (function
5599           (lambda (f) (or
5600                        (string-equal f ".")
5601                        (string-equal f "..")
5602                        (member f clearcase-directory-exclusion-list)
5603                        (let ((dirf (concat dir f)))
5604                          (or
5605                           (file-symlink-p dirf) ;; Avoid possible loops
5606                           (clearcase-subdir-tree-walk-internal dirf
5607                                                                func
5608                                                                args
5609                                                                quiet))))))
5610          (directory-files dir)))))
5611
5612 ;;}}}
5613
5614 ;;{{{ Buffer context
5615
5616 ;; nyi: it would be nice if we could restore fold context too, for folded files.
5617
5618 ;; Save a bit of the text around POSN in the current buffer, to help
5619 ;; us find the corresponding position again later.  This works even
5620 ;; if all markers are destroyed or corrupted.
5621 ;;
5622 (defun clearcase-position-context (posn)
5623   (list posn
5624         (buffer-size)
5625         (buffer-substring posn
5626                           (min (point-max) (+ posn 100)))))
5627
5628 ;; Return the position of CONTEXT in the current buffer, or nil if we
5629 ;; couldn't find it.
5630 ;;
5631 (defun clearcase-find-position-by-context (context)
5632   (let ((context-string (nth 2 context)))
5633     (if (equal "" context-string)
5634         (point-max)
5635       (save-excursion
5636         (let ((diff (- (nth 1 context) (buffer-size))))
5637           (if (< diff 0) (setq diff (- diff)))
5638           (goto-char (nth 0 context))
5639           (if (or (search-forward context-string nil t)
5640                   ;; Can't use search-backward since the match may continue
5641                   ;; after point.
5642                   ;;
5643                   (progn (goto-char (- (point) diff (length context-string)))
5644                          ;; goto-char doesn't signal an error at
5645                          ;; beginning of buffer like backward-char would.
5646                          ;;
5647                          (search-forward context-string nil t)))
5648               ;; to beginning of OSTRING
5649               ;;
5650               (- (point) (length context-string))))))))
5651
5652 ;;}}}
5653
5654 ;;{{{ Synchronizing buffers with disk
5655
5656 (defun clearcase-sync-after-file-updated-from-vob (file)
5657   ;; Do what is needed after a file in a snapshot is updated or a checkout is
5658   ;; cancelled.
5659
5660   ;; "ct+update" will not always make the file readonly, if, for
5661   ;; example, its contents didn't actually change.  But we'd like
5662   ;; update to result in a readonly file, so force it here.
5663   ;;
5664   (clearcase-utl-make-unwriteable file)
5665
5666   (or
5667    ;; If this returns true, there was a buffer visiting the file and it it
5668    ;; flushed fprops...
5669    ;;
5670    (clearcase-sync-from-disk-if-needed file)
5671
5672    ;; ...otherwise, just sync this other state:
5673    ;;
5674    (progn
5675      (clearcase-fprop-unstore-properties file)
5676      (dired-relist-file file))))
5677
5678 (defun clearcase-sync-from-disk (file &optional no-confirm)
5679
5680   (clearcase-fprop-unstore-properties file)
5681   ;; If the given file is in any buffer, revert it.
5682   ;;
5683   (let ((buffer (find-buffer-visiting file)))
5684     (if buffer
5685         (save-excursion
5686           (set-buffer buffer)
5687           (clearcase-buffer-revert no-confirm)
5688           (clearcase-fprop-get-properties file)
5689
5690           ;; Make sure the mode-line gets updated.
5691           ;;
5692           (setq clearcase-mode
5693                 (concat " ClearCase:"
5694                         (clearcase-mode-line-buffer-id file)))
5695           (force-mode-line-update))))
5696
5697   ;; Update any Dired Mode buffers that list this file.
5698   ;;
5699   (dired-relist-file file)
5700
5701   ;; If the file was a directory, update any dired-buffer for
5702   ;; that directory.
5703   ;;
5704   (mapcar (function (lambda (buffer)
5705                       (save-excursion
5706                         (set-buffer buffer)
5707                         (revert-buffer))))
5708           (dired-buffers-for-dir file)))
5709
5710 (defun clearcase-sync-from-disk-if-needed (file)
5711
5712   ;; If the buffer on FILE is out of sync with its file, synch it. Returns t if
5713   ;; clearcase-sync-from-disk is called.
5714
5715   (let ((buffer (find-buffer-visiting file)))
5716     (if (and buffer
5717              ;; Buffer can be out of sync in two ways:
5718              ;;  (a) Buffer is modified (hasn't been written)
5719              ;;  (b) Buffer is recording a different modtime to what the file has.
5720              ;;      This is what happens when the file is updated by another
5721              ;;      process.
5722              ;;  (c) Buffer and file differ in their writeability.
5723              ;;
5724              (or (buffer-modified-p buffer)
5725                  (not (verify-visited-file-modtime buffer))
5726                  (eq (file-writable-p file)
5727                      (with-current-buffer buffer buffer-read-only))))
5728         (progn
5729           (clearcase-sync-from-disk file
5730                                     ;; Only confirm for modified buffers.
5731                                     ;;
5732                                     (not (buffer-modified-p buffer)))
5733           t)
5734       nil)))
5735
5736
5737 (defun clearcase-sync-to-disk (&optional not-urgent)
5738
5739   ;; Make sure the current buffer and its working file are in sync
5740   ;; NOT-URGENT means it is ok to continue if the user says not to save.
5741   ;;
5742   (if (buffer-modified-p)
5743       (if (or clearcase-suppress-confirm
5744               (y-or-n-p (format "Buffer %s modified; save it? "
5745                                 (buffer-name))))
5746           (save-buffer)
5747         (if not-urgent
5748             nil
5749           (error "Aborted")))))
5750
5751
5752 (defun clearcase-buffer-revert (&optional no-confirm)
5753   ;; Should never call for Dired buffers
5754   ;;
5755   (assert (not (eq major-mode 'dired-mode)))
5756
5757   ;; Revert buffer, try to keep point and mark where user expects them in spite
5758   ;; of changes because of expanded version-control key words.  This is quite
5759   ;; important since otherwise typeahead won't work as expected.
5760   ;;
5761   (widen)
5762   (let ((point-context (clearcase-position-context (point)))
5763
5764         ;; Use clearcase-utl-mark-marker to avoid confusion in transient-mark-mode.
5765         ;; XEmacs - mark-marker t, FSF Emacs - mark-marker.
5766         ;;
5767         (mark-context (if (eq (marker-buffer (clearcase-utl-mark-marker))
5768                               (current-buffer))
5769                           (clearcase-position-context (clearcase-utl-mark-marker))))
5770         (camefrom (current-buffer)))
5771
5772     ;; nyi: Should we run font-lock ?
5773     ;; Want to avoid re-doing a buffer that is already correct, such as on
5774     ;; check-in/check-out.
5775     ;; For now do-nothing.
5776
5777     ;; The actual revisit.
5778     ;; For some reason, revert-buffer doesn't recompute whether View Minor Mode
5779     ;; should be on, so turn it off and then turn it on if necessary.
5780     ;;
5781     ;; nyi: Perhaps we should re-find-file ?
5782     ;;
5783     (or clearcase-xemacs-p
5784         (if (fboundp 'view-mode)
5785             (view-mode 0)))
5786     (revert-buffer t no-confirm t)
5787     (or clearcase-xemacs-p
5788         (if (and (boundp 'view-read-only)
5789                  view-read-only
5790                  buffer-read-only)
5791             (view-mode 1)))
5792
5793     ;; Restore point and mark.
5794     ;;
5795     (let ((new-point (clearcase-find-position-by-context point-context)))
5796       (if new-point
5797           (goto-char new-point))
5798       (if mark-context
5799           (let ((new-mark (clearcase-find-position-by-context mark-context)))
5800             (if new-mark
5801                 (set-mark new-mark))))
5802
5803       ;; Restore a semblance of folded state.
5804       ;;
5805       (if (and (boundp 'folded-file)
5806                folded-file)
5807           (progn
5808             (folding-open-buffer)
5809             (folding-whole-buffer)
5810             (if new-point
5811                 (folding-goto-char new-point)))))))
5812
5813 ;;}}}
5814
5815 ;;{{{ Utilities
5816
5817 ;;{{{ Displaying content in special buffers
5818
5819 (defun clearcase-utl-populate-and-view-buffer (buffer
5820                                                args
5821                                                content-generating-func)
5822   "Empty BUFFER, and populate it by applying to ARGS the CONTENT-GENERATING-FUNC,
5823 and display in a separate window."
5824
5825   (clearcase-utl-edit-and-view-buffer
5826    buffer
5827    (list args)
5828    (function
5829     (lambda (args)
5830       (erase-buffer)
5831       (apply content-generating-func args)))))
5832
5833 (defun clearcase-utl-edit-and-view-buffer (buffer
5834                                            args
5835                                            content-editing-func)
5836   "Empty BUFFER, and edit it by applying to ARGS the CONTENT-EDITING-FUNC,
5837 and display in a separate window."
5838
5839   (let ( ;; Create the buffer if necessary.
5840         ;;
5841         (buf (get-buffer-create buffer))
5842
5843         ;; Record where we came from.
5844         ;;
5845         (camefrom (current-buffer)))
5846
5847     (set-buffer buf)
5848     (clearcase-view-mode 0 camefrom)
5849
5850     ;; Edit the buffer.
5851     ;;
5852     (apply content-editing-func args)
5853
5854     ;; Display the buffer.
5855     ;;
5856     (clearcase-port-view-buffer-other-window buf)
5857     (goto-char 0)
5858     (set-buffer-modified-p nil)         ; XEmacs - fsf uses `not-modified'
5859     (shrink-window-if-larger-than-buffer)))
5860
5861 ;;}}}
5862
5863 ;;{{{ Temporary files
5864
5865 (defvar clearcase-tempfiles nil)
5866 (defun clearcase-utl-tempfile-name (&optional vxpath)
5867   (let ((ext ""))
5868     (and vxpath
5869          (save-match-data
5870            (if (string-match "\\(\\.[^.]+\\)@@" vxpath)
5871                (setq ext (match-string 1 vxpath)))))
5872     (let ((filename (concat
5873                      (make-temp-name (clearcase-path-canonical
5874                                       ;; Use TEMP e.v. if set.
5875                                       ;;
5876                                       (concat (or (getenv "TEMP") "/tmp")
5877                                               "/clearcase-")))
5878                      ext)))
5879       ;; Store its name for later cleanup.
5880       ;;
5881       (setq clearcase-tempfiles (cons filename clearcase-tempfiles))
5882       filename)))
5883
5884 (defun clearcase-utl-clean-tempfiles ()
5885   (mapcar (function
5886            (lambda (tempfile)
5887              (if (file-exists-p tempfile)
5888                  (condition-case nil
5889                      (delete-file tempfile)
5890                    (error nil)))))
5891           clearcase-tempfiles)
5892   (setq clearcase-tempfiles nil))
5893
5894 ;;}}}
5895
5896 (defun clearcase-utl-touch-file (file)
5897   "Attempt to update the modtime of FILE. Return t if it worked."
5898   (zerop
5899    ;; Silently fail if there is no "touch" command available.  Couldn't find a
5900    ;; convenient way to update a file's modtime in ELisp.
5901    ;;
5902    (condition-case nil
5903        (prog1
5904          (shell-command (concat "touch " file))
5905          (message ""))
5906      (error nil))))
5907
5908 (defun clearcase-utl-filetimes-close (filetime1 filetime2 tolerance)
5909   "Test if FILETIME1 and FILETIME2 are within TOLERANCE of each other."
5910   ;; nyi: To do this correctly we need to know MAXINT.
5911   ;; For now this is correct enough since we only use this as a guideline to
5912   ;; avoid generating a diff.
5913   ;;
5914   (if (equal (first filetime1) (first filetime2))
5915       (< (abs (- (second filetime1) (second filetime2))) tolerance)
5916     nil))
5917
5918 (defun clearcase-utl-emacs-date-to-clearcase-date (s)
5919   (concat
5920    (substring s 20) ;; yyyy
5921    (int-to-string (clearcase-utl-month-unparse (substring s 4 7))) ;; mm
5922    (substring s 8 10) ;; dd
5923    "."
5924    (substring s 11 13) ;; hh
5925    (substring s 14 16) ;; mm
5926    (substring s 17 19))) ;; ss
5927
5928 (defun clearcase-utl-month-unparse (s)
5929   (cond
5930    ((string= s "Jan") 1)
5931    ((string= s "Feb") 2)
5932    ((string= s "Mar") 3)
5933    ((string= s "Apr") 4)
5934    ((string= s "May") 5)
5935    ((string= s "Jun") 6)
5936    ((string= s "Jul") 7)
5937    ((string= s "Aug") 8)
5938    ((string= s "Sep") 9)
5939    ((string= s "Oct") 10)
5940    ((string= s "Nov") 11)
5941    ((string= s "Dec") 12)))
5942
5943 (defun clearcase-utl-strip-trailing-slashes (name)
5944   (let* ((len (length name)))
5945     (while (and (> len 1)
5946                 (or (equal ?/ (aref name (1- len)))
5947                     (equal ?\\ (aref name (1- len)))))
5948       (setq len (1- len)))
5949     (substring name 0 len)))
5950
5951 (defun clearcase-utl-file-size (file)
5952   (nth 7 (file-attributes file)))
5953 (defun clearcase-utl-file-atime (file)
5954   (nth 4 (file-attributes file)))
5955 (defun clearcase-utl-file-mtime (file)
5956   (nth 5 (file-attributes file)))
5957 (defun clearcase-utl-file-ctime (file)
5958   (nth 6 (file-attributes file)))
5959
5960 (defun clearcase-utl-kill-view-buffer ()
5961   (interactive)
5962   (let ((buf (current-buffer)))
5963     (delete-windows-on buf)
5964     (kill-buffer buf)))
5965
5966 (defun clearcase-utl-escape-double-quotes (s)
5967   "Escape any double quotes in string S"
5968   (mapconcat (function (lambda (char)
5969                          (if (equal ?\" char)
5970                              (string ?\\ char)
5971                            (string char))))
5972              s
5973              ""))
5974
5975 (defun clearcase-utl-escape-backslashes (s)
5976   "Double any backslashes in string S"
5977   (mapconcat (function (lambda (char)
5978                          (if (equal ?\\ char)
5979                              "\\\\"
5980                            (string char))))
5981              s
5982              ""))
5983
5984 (defun clearcase-utl-quote-if-nec (token)
5985   "If TOKEN contains whitespace and is not already quoted,
5986 wrap it in double quotes."
5987   (if (and (string-match "[ \t]" token)
5988            (not (equal ?\" (aref token 0)))
5989            (not (equal ?\' (aref token 0))))
5990       (concat "\"" token "\"")
5991     token))
5992
5993 (defun clearcase-utl-or-func (&rest args)
5994   "A version of `or' that can be applied to a list."
5995   (let ((result nil)
5996         (cursor args))
5997     (while (and (null result)
5998                 cursor)
5999       (if (car cursor)
6000           (setq result t))
6001       (setq cursor (cdr cursor)))
6002     result))
6003
6004 (defun clearcase-utl-any (predicate list)
6005   "Returns t if PREDICATE is satisfied by any element in LIST."
6006   (let ((result nil)
6007         (cursor list))
6008     (while (and (null result)
6009                 cursor)
6010       (if (funcall predicate (car cursor))
6011           (setq result t))
6012       (setq cursor (cdr cursor)))
6013     result))
6014
6015 (defun clearcase-utl-every (predicate list)
6016   "Returns t if PREDICATE is satisfied by every element in LIST."
6017   (let ((result t)
6018         (cursor list))
6019     (while (and result
6020                 cursor)
6021       (if (not (funcall predicate (car cursor)))
6022           (setq result nil))
6023       (setq cursor (cdr cursor)))
6024     result))
6025
6026 (defun clearcase-utl-list-filter (predicate list)
6027   "Map PREDICATE over each element of LIST, and return a list of the elements
6028 that mapped to non-nil."
6029   (let ((result '())
6030         (cursor list))
6031     (while (not (null cursor))
6032       (let ((elt (car cursor)))
6033         (if (funcall predicate elt)
6034             (setq result (cons elt result)))
6035         (setq cursor (cdr cursor))))
6036     (nreverse result)))
6037
6038 (defun clearcase-utl-elts-are-eq (l)
6039   "Test if all elements of LIST are eq."
6040   (if (null l)
6041       t
6042     (let ((head (car l))
6043           (answer t))
6044       (mapcar (function (lambda (elt)
6045                           (if (not (eq elt head))
6046                               (setq answer nil))))
6047               (cdr l))
6048       answer)))
6049
6050 ;; FSF Emacs - doesn't like parameters on mark-marker.
6051 ;;
6052 (defun clearcase-utl-mark-marker ()
6053   (if clearcase-xemacs-p
6054       (mark-marker t)
6055     (mark-marker)))
6056
6057 (defun clearcase-utl-syslog (buf value)
6058   (save-excursion
6059     (let ((tmpbuf (get-buffer buf)))
6060       (if (bufferp tmpbuf)
6061           (progn
6062             (set-buffer buf)
6063             (goto-char (point-max))
6064             (insert (format "%s\n" value)))))))
6065
6066 ;; Extract the first line of a string.
6067 ;;
6068 (defun clearcase-utl-1st-line-of-string (s)
6069   (let ((newline ?\n)
6070         (len (length s))
6071         (i 0))
6072     (while (and (< i len)
6073                 (not (eq newline
6074                          (aref s i))))
6075       (setq i (1+ i)))
6076     (substring s 0 i)))
6077
6078 (defun clearcase-utl-split-string (str pat &optional indir suffix)
6079   (let ((ret nil)
6080         (start 0)
6081         (last (length str)))
6082     (while (< start last)
6083       (if (string-match pat str start)
6084           (progn
6085             (let ((tmp (substring str start (match-beginning 0))))
6086               (if suffix (setq tmp (concat tmp suffix)))
6087               (setq ret (cons (if indir (cons tmp nil)
6088                                 tmp)
6089                               ret)))
6090             (setq start (match-end 0)))
6091         (setq start last)
6092         (setq ret (cons (substring str start) ret))))
6093     (nreverse ret)))
6094
6095 (defun clearcase-utl-split-string-at-char (str char)
6096   (let ((ret nil)
6097         (i 0)
6098         (eos (length str)))
6099     (while (< i eos)
6100       ;; Collect next token
6101       ;;
6102       (let ((token-begin i))
6103         ;; Find the end
6104         ;;
6105         (while (and (< i eos)
6106                     (not (eq char (aref str i))))
6107           (setq i (1+ i)))
6108
6109         (setq ret (cons (substring str token-begin i)
6110                         ret))
6111         (setq i (1+ i))))
6112     (nreverse ret)))
6113
6114
6115 (defun clearcase-utl-add-env (env var)
6116   (catch 'return
6117     (let ((a env)
6118           (vname (substring var 0
6119                             (and (string-match "=" var)
6120                                  (match-end 0)))))
6121       (let ((vnl (length vname)))
6122         (while a
6123           (if (and (> (length (car a)) vnl)
6124                    (string= (substring (car a) 0 vnl)
6125                             vname))
6126               (throw 'return env))
6127           (setq a (cdr a)))
6128         (cons var env)))))
6129
6130
6131 (defun clearcase-utl-augment-env-from-view-config-spec (old-env tag &optional add-ons)
6132   (let ((newenv nil)
6133         (cc-env (clearcase-misc-extract-evs-from-config-spe tag)))
6134
6135     ;; 1. Add-on bindings at the front:
6136     ;;
6137     (while add-ons
6138       (setq newenv (clearcase-utl-add-env newenv (car add-ons)))
6139       (setq add-ons (cdr add-ons)))
6140
6141     ;; 2. Then bindings defined in the config-spec:
6142     ;;
6143     (while cc-env
6144       (setq newenv (clearcase-utl-add-env newenv (car cc-env)))
6145       (setq cc-env (cdr cc-env)))
6146
6147     ;; 3. Lastly bindings that were in the old environment.
6148     ;;
6149     (while old-env
6150       (setq newenv (clearcase-utl-add-env newenv (car old-env)))
6151       (setq old-env (cdr old-env)))
6152     newenv))
6153
6154 (defun clearcase-utl-make-writeable (file)
6155   ;; Equivalent to chmod u+w
6156   ;;
6157   (set-file-modes file
6158                   (logior #o0200 (file-modes file))))
6159
6160 (defun clearcase-utl-make-unwriteable (file)
6161   ;; Equivalent to chmod u-w
6162   ;;
6163   (set-file-modes file
6164                   (logand #o7577 (file-modes file))))
6165
6166 ;;}}}
6167
6168 ;;}}}
6169
6170 ;;{{{ Menus
6171
6172 ;; Predicate to determine if ClearCase menu items are relevant.
6173 ;; nyi" this should disappear
6174 ;;
6175 (defun clearcase-buffer-contains-version-p ()
6176   "Return true if the current buffer contains a ClearCase file or directory."
6177   (let ((object-name (if (eq major-mode 'dired-mode)
6178                          default-directory
6179                        buffer-file-name)))
6180     (clearcase-fprop-file-is-version-p object-name)))
6181
6182 ;;{{{ clearcase-mode menu
6183
6184 ;;{{{ The contents
6185
6186 ;; This version of the menu will hide rather than grey out inapplicable entries.
6187 ;;
6188 (defvar clearcase-menu-contents-minimised
6189   (list "ClearCase"
6190
6191         ["Checkin" clearcase-checkin-current-buffer
6192          :keys nil
6193          :visible (clearcase-file-ok-to-checkin buffer-file-name)]
6194
6195         ["Edit checkout comment" clearcase-edit-checkout-comment-current-buffer
6196          :keys nil
6197          :visible (clearcase-file-ok-to-checkin buffer-file-name)]
6198
6199         ["Checkout" clearcase-checkout-current-buffer
6200          :keys nil
6201          :visible (clearcase-file-ok-to-checkout buffer-file-name)]
6202
6203         ["Hijack" clearcase-hijack-current-buffer
6204          :keys nil
6205          :visible (clearcase-file-ok-to-hijack buffer-file-name)]
6206
6207         ["Unhijack" clearcase-unhijack-current-buffer
6208          :keys nil
6209          :visible (clearcase-file-ok-to-unhijack buffer-file-name)]
6210
6211         ["Uncheckout" clearcase-uncheckout-current-buffer
6212          :visible (clearcase-file-ok-to-uncheckout buffer-file-name)]
6213
6214         ["Find checkouts" clearcase-find-checkouts-in-current-view t]
6215
6216         ["Make element" clearcase-mkelem-current-buffer
6217          :visible (clearcase-file-ok-to-mkelem buffer-file-name)]
6218
6219         "---------------------------------"
6220         ["Describe version" clearcase-describe-current-buffer
6221          :visible (clearcase-buffer-contains-version-p)]
6222
6223         ["Describe file" clearcase-describe-current-buffer
6224          :visible (not (clearcase-buffer-contains-version-p))]
6225
6226         ["Annotate version" clearcase-annotate-current-buffer
6227          :visible (clearcase-buffer-contains-version-p)]
6228
6229         ["Show config-spec rule" clearcase-what-rule-current-buffer
6230          :visible (clearcase-buffer-contains-version-p)]
6231
6232         ;; nyi: enable this also when setviewed ?
6233         ;;
6234         ["Edit config-spec" clearcase-edcs-edit t]
6235
6236         "---------------------------------"
6237         (list "Compare (Emacs)..."
6238               ["Compare with predecessor" clearcase-ediff-pred-current-buffer
6239                :keys nil
6240                :visible (clearcase-buffer-contains-version-p)]
6241               ["Compare with branch base" clearcase-ediff-branch-base-current-buffer
6242                :keys nil
6243                :visible (clearcase-buffer-contains-version-p)]
6244               ["Compare with named version" clearcase-ediff-named-version-current-buffer
6245                :keys nil
6246                :visible (clearcase-buffer-contains-version-p)])
6247         (list "Compare (GUI)..."
6248               ["Compare with predecessor" clearcase-gui-diff-pred-current-buffer
6249                :keys nil
6250                :visible (clearcase-buffer-contains-version-p)]
6251               ["Compare with branch base" clearcase-gui-diff-branch-base-current-buffer
6252                :keys nil
6253                :visible (clearcase-buffer-contains-version-p)]
6254               ["Compare with named version" clearcase-gui-diff-named-version-current-buffer
6255                :keys nil
6256                :visible (clearcase-buffer-contains-version-p)])
6257         (list "Compare (diff)..."
6258               ["Compare with predecessor" clearcase-diff-pred-current-buffer
6259                :keys nil
6260                :visible (clearcase-buffer-contains-version-p)]
6261               ["Compare with branch base" clearcase-diff-branch-base-current-buffer
6262                :keys nil
6263                :visible (clearcase-buffer-contains-version-p)]
6264               ["Compare with named version" clearcase-diff-named-version-current-buffer
6265                :keys nil
6266                :visible (clearcase-buffer-contains-version-p)])
6267         "---------------------------------"
6268         ["Browse versions (dired)" clearcase-browse-vtree-current-buffer
6269          :visible (clearcase-file-ok-to-browse buffer-file-name)]
6270         ["Vtree browser GUI" clearcase-gui-vtree-browser-current-buffer
6271          :keys nil
6272          :visible (clearcase-buffer-contains-version-p)]
6273         "---------------------------------"
6274         (list "Update snapshot..."
6275               ["Update view" clearcase-update-view
6276                :keys nil
6277                :visible (and (clearcase-file-is-in-view-p default-directory)
6278                              (not (clearcase-file-is-in-mvfs-p default-directory)))]
6279               ["Update directory" clearcase-update-default-directory
6280                :keys nil
6281                :visible (and (clearcase-file-is-in-view-p default-directory)
6282                              (not (clearcase-file-is-in-mvfs-p default-directory)))]
6283               ["Update this file" clearcase-update-current-buffer
6284                :keys nil
6285                :visible (and (clearcase-file-ok-to-checkout buffer-file-name)
6286                              (not (clearcase-file-is-in-mvfs-p buffer-file-name)))]
6287               )
6288         "---------------------------------"
6289         (list "Element history..."
6290               ["Element history (full)" clearcase-list-history-current-buffer
6291                :keys nil
6292                :visible (clearcase-buffer-contains-version-p)]
6293               ["Element history (branch)" clearcase-list-history-current-buffer
6294                :keys nil
6295                :visible (clearcase-buffer-contains-version-p)]
6296               ["Element history (me)" clearcase-list-history-current-buffer
6297                :keys nil
6298                :visible (clearcase-buffer-contains-version-p)])
6299         "---------------------------------"
6300         ["Show current activity" clearcase-ucm-describe-current-activity
6301          :keys nil
6302          :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6303         ["Make activity" clearcase-ucm-mkact-current-dir
6304          :keys nil
6305          :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6306         ["Set activity..." clearcase-ucm-set-activity-current-dir
6307          :keys nil
6308          :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6309         ["Set NO activity" clearcase-ucm-set-activity-none-current-dir
6310          :keys nil
6311          :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6312         ["Rebase this stream" clearcase-gui-rebase
6313          :keys nil
6314          :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6315         ["Deliver from this stream" clearcase-gui-deliver
6316          :keys nil
6317          :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6318         "---------------------------------"
6319         (list "ClearCase GUI"
6320               ["ClearCase Explorer" clearcase-gui-clearexplorer
6321                :keys nil
6322                :visible clearcase-on-mswindows]
6323               ["Project Explorer" clearcase-gui-project-explorer
6324                :keys nil]
6325               ["Merge Manager" clearcase-gui-merge-manager
6326                :keys nil]
6327               ["Snapshot View Updater" clearcase-gui-snapshot-view-updater
6328                :keys nil])
6329         "---------------------------------"
6330
6331         ;; nyi:
6332         ;; Enable this when current buffer is on VOB.
6333         ;;
6334         ["Make branch type" clearcase-mkbrtype
6335          :keys nil]
6336
6337         "---------------------------------"
6338         ["Report Bug in ClearCase Mode" clearcase-submit-bug-report
6339          :keys nil]
6340
6341         ["Dump internals" clearcase-dump
6342          :keys nil
6343          :visible (or (equal "rwhitby" (user-login-name))
6344                       (equal "esler" (user-login-name)))]
6345
6346         ["Flush caches" clearcase-flush-caches
6347          :keys nil
6348          :visible (or (equal "rwhitby" (user-login-name))
6349                       (equal "esler" (user-login-name)))]
6350
6351         "---------------------------------"
6352         ["Customize..." (customize-group 'clearcase)
6353          :keys nil]))
6354
6355 (defvar clearcase-menu-contents
6356   (list "ClearCase"
6357
6358         ["Checkin" clearcase-checkin-current-buffer
6359          :keys nil
6360          :active (clearcase-file-ok-to-checkin buffer-file-name)]
6361
6362         ["Edit checkout comment" clearcase-edit-checkout-comment-current-buffer
6363          :keys nil
6364          :active (clearcase-file-ok-to-checkin buffer-file-name)]
6365
6366         ["Checkout" clearcase-checkout-current-buffer
6367          :keys nil
6368          :active (clearcase-file-ok-to-checkout buffer-file-name)]
6369
6370         ["Hijack" clearcase-hijack-current-buffer
6371          :keys nil
6372          :active (clearcase-file-ok-to-hijack buffer-file-name)]
6373
6374         ["Unhijack" clearcase-unhijack-current-buffer
6375          :keys nil
6376          :active (clearcase-file-ok-to-unhijack buffer-file-name)]
6377
6378         ["Uncheckout" clearcase-uncheckout-current-buffer
6379          :active (clearcase-file-ok-to-uncheckout buffer-file-name)]
6380
6381         ["Make element" clearcase-mkelem-current-buffer
6382          :active (clearcase-file-ok-to-mkelem buffer-file-name)]
6383
6384         "---------------------------------"
6385         ["Describe version" clearcase-describe-current-buffer
6386          :active (clearcase-buffer-contains-version-p)]
6387
6388         ["Describe file" clearcase-describe-current-buffer
6389          :active (not (clearcase-buffer-contains-version-p))]
6390
6391         ["Annotate version" clearcase-annotate-current-buffer
6392          :keys nil
6393          :active (clearcase-buffer-contains-version-p)]
6394
6395         ["Show config-spec rule" clearcase-what-rule-current-buffer
6396          :active (clearcase-buffer-contains-version-p)]
6397
6398         ;; nyi: enable this also when setviewed ?
6399         ;;
6400         ["Edit config-spec" clearcase-edcs-edit t]
6401
6402         "---------------------------------"
6403         (list "Compare (Emacs)..."
6404               ["Compare with predecessor" clearcase-ediff-pred-current-buffer
6405                :keys nil
6406                :active (clearcase-buffer-contains-version-p)]
6407               ["Compare with branch base" clearcase-ediff-branch-base-current-buffer
6408                :keys nil
6409                :active (clearcase-buffer-contains-version-p)]
6410               ["Compare with named version" clearcase-ediff-named-version-current-buffer
6411                :keys nil
6412                :active (clearcase-buffer-contains-version-p)])
6413         (list "Compare (GUI)..."
6414               ["Compare with predecessor" clearcase-gui-diff-pred-current-buffer
6415                :keys nil
6416                :active (clearcase-buffer-contains-version-p)]
6417               ["Compare with branch base" clearcase-gui-diff-branch-base-current-buffer
6418                :keys nil
6419                :active (clearcase-buffer-contains-version-p)]
6420               ["Compare with named version" clearcase-gui-diff-named-version-current-buffer
6421                :keys nil
6422                :active (clearcase-buffer-contains-version-p)])
6423         (list "Compare (diff)..."
6424               ["Compare with predecessor" clearcase-diff-pred-current-buffer
6425                :keys nil
6426                :active (clearcase-buffer-contains-version-p)]
6427               ["Compare with branch base" clearcase-diff-branch-base-current-buffer
6428                :keys nil
6429                :active (clearcase-buffer-contains-version-p)]
6430               ["Compare with named version" clearcase-diff-named-version-current-buffer
6431                :keys nil
6432                :active (clearcase-buffer-contains-version-p)])
6433         "---------------------------------"
6434         ["Browse versions (dired)" clearcase-browse-vtree-current-buffer
6435          :active (clearcase-file-ok-to-browse buffer-file-name)]
6436         ["Vtree browser GUI" clearcase-gui-vtree-browser-current-buffer
6437          :keys nil
6438          :active (clearcase-buffer-contains-version-p)]
6439         "---------------------------------"
6440         (list "Update snapshot..."
6441               ["Update view" clearcase-update-view
6442                :keys nil
6443                :active (and (clearcase-file-is-in-view-p default-directory)
6444                             (not (clearcase-file-is-in-mvfs-p default-directory)))]
6445               ["Update directory" clearcase-update-default-directory
6446                :keys nil
6447                :active (and (clearcase-file-is-in-view-p default-directory)
6448                             (not (clearcase-file-is-in-mvfs-p default-directory)))]
6449               ["Update this file" clearcase-update-current-buffer
6450                :keys nil
6451                :active (and (clearcase-file-ok-to-checkout buffer-file-name)
6452                             (not (clearcase-file-is-in-mvfs-p buffer-file-name)))]
6453               )
6454         "---------------------------------"
6455         (list "Element history..."
6456               ["Element history (full)" clearcase-list-history-current-buffer
6457                :keys nil
6458                :active (clearcase-buffer-contains-version-p)]
6459               ["Element history (branch)" clearcase-list-history-current-buffer
6460                :keys nil
6461                :active (clearcase-buffer-contains-version-p)]
6462               ["Element history (me)" clearcase-list-history-current-buffer
6463                :keys nil
6464                :active (clearcase-buffer-contains-version-p)])
6465         "---------------------------------"
6466         ["Show current activity" clearcase-ucm-describe-current-activity
6467          :keys nil
6468          :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6469         ["Make activity" clearcase-ucm-mkact-current-dir
6470          :keys nil
6471          :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6472         ["Set activity..." clearcase-ucm-set-activity-current-dir
6473          :keys nil
6474          :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6475         ["Set NO activity" clearcase-ucm-set-activity-none-current-dir
6476          :keys nil
6477          :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6478         ["Rebase this stream" clearcase-gui-rebase
6479          :keys nil
6480          :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6481         ["Deliver from this stream" clearcase-gui-deliver
6482          :keys nil
6483          :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6484         "---------------------------------"
6485         (list "ClearCase GUI"
6486               ["ClearCase Explorer" clearcase-gui-clearexplorer
6487                :keys nil
6488                :active clearcase-on-mswindows]
6489               ["Project Explorer" clearcase-gui-project-explorer
6490                :keys nil]
6491               ["Merge Manager" clearcase-gui-merge-manager
6492                :keys nil]
6493               ["Snapshot View Updater" clearcase-gui-snapshot-view-updater
6494                :keys nil])
6495         "---------------------------------"
6496
6497         ;; nyi:
6498         ;; Enable this when current buffer is on VOB.
6499         ;;
6500         ["Make branch type" clearcase-mkbrtype
6501          :keys nil]
6502
6503         "---------------------------------"
6504         ["Report Bug in ClearCase Mode" clearcase-submit-bug-report
6505          :keys nil]
6506
6507         ["Dump internals" clearcase-dump
6508          :keys nil
6509          :active (or (equal "rwhitby" (user-login-name))
6510                      (equal "esler" (user-login-name)))]
6511
6512         ["Flush caches" clearcase-flush-caches
6513          :keys nil
6514          :active (or (equal "rwhitby" (user-login-name))
6515                      (equal "esler" (user-login-name)))]
6516
6517         "---------------------------------"
6518         ["Customize..." (customize-group 'clearcase)
6519          :keys nil]))
6520
6521 (if (and clearcase-minimise-menus
6522          (not clearcase-xemacs-p))
6523     (setq clearcase-menu-contents clearcase-menu-contents-minimised))
6524
6525 ;;}}}1
6526
6527 (if (>= emacs-major-version '20)
6528     (progn
6529       ;; Define the menu
6530       ;;
6531       (easy-menu-define
6532         clearcase-menu
6533         (list clearcase-mode-map)
6534         "ClearCase menu"
6535         clearcase-menu-contents)
6536
6537       (or clearcase-xemacs-p
6538           (add-to-list 'menu-bar-final-items 'ClearCase))))
6539
6540 ;;}}}
6541
6542 ;;{{{ clearcase-dired-mode menu
6543
6544 ;;{{{ Related functions
6545
6546 ;; nyi: this probably gets run for each menu element.
6547 ;;      For better efficiency, look into using a one-pass ":filter"
6548 ;;      to construct this menu dynamically.
6549
6550 (defun clearcase-dired-mark-count ()
6551   (let ((old-point (point))
6552         (count 0))
6553     (goto-char (point-min))
6554     (while (re-search-forward
6555             (concat "^" (regexp-quote (char-to-string
6556                                        dired-marker-char))) nil t)
6557       (setq count (1+ count)))
6558     (goto-char old-point)
6559     count))
6560
6561 (defun clearcase-dired-current-ok-to-checkin ()
6562   (let ((file (dired-get-filename nil t)))
6563     (and file
6564          (clearcase-file-ok-to-checkin file))))
6565
6566 (defun clearcase-dired-current-ok-to-checkout ()
6567   (let ((file (dired-get-filename nil t)))
6568     (and file
6569          (clearcase-file-ok-to-checkout file))))
6570
6571 (defun clearcase-dired-current-ok-to-uncheckout ()
6572   (let ((file (dired-get-filename nil t)))
6573     (and file
6574          (clearcase-file-ok-to-uncheckout file))))
6575
6576 (defun clearcase-dired-current-ok-to-hijack ()
6577   (let ((file (dired-get-filename nil t)))
6578     (and file
6579          (clearcase-file-ok-to-hijack file))))
6580
6581 (defun clearcase-dired-current-ok-to-unhijack ()
6582   (let ((file (dired-get-filename nil t)))
6583     (and file
6584          (clearcase-file-ok-to-unhijack file))))
6585
6586 (defun clearcase-dired-current-ok-to-mkelem ()
6587   (let ((file (dired-get-filename nil t)))
6588     (and file
6589          (clearcase-file-ok-to-mkelem file))))
6590
6591 (defun clearcase-dired-current-ok-to-browse ()
6592   (let ((file (dired-get-filename nil t)))
6593     (clearcase-file-ok-to-browse file)))
6594
6595 (defvar clearcase-dired-max-marked-files-to-check 5
6596   "The maximum number of marked files in a Dired buffer when constructing
6597 the ClearCase menu.")
6598
6599 ;; nyi: speed these up by stopping check when a non-qualifying file is found
6600 ;; Better:
6601 ;;   - hook the menu constuction  and figure out what ops apply
6602 ;;   - hook mark/unmark/move cursor
6603
6604 (defun clearcase-dired-marked-ok-to-checkin ()
6605   (let ((files (dired-get-marked-files)))
6606     (or (> (length files) clearcase-dired-max-marked-files-to-check)
6607         (clearcase-utl-every (function clearcase-file-ok-to-checkin)
6608                              files))))
6609
6610 (defun clearcase-dired-marked-ok-to-checkout ()
6611   (let ((files (dired-get-marked-files)))
6612     (or (> (length files) clearcase-dired-max-marked-files-to-check)
6613         (clearcase-utl-every (function clearcase-file-ok-to-checkout)
6614                              files))))
6615
6616 (defun clearcase-dired-marked-ok-to-uncheckout ()
6617   (let ((files (dired-get-marked-files)))
6618     (or (> (length files) clearcase-dired-max-marked-files-to-check)
6619         (clearcase-utl-every (function clearcase-file-ok-to-uncheckout)
6620                              files))))
6621
6622 (defun clearcase-dired-marked-ok-to-hijack ()
6623   (let ((files (dired-get-marked-files)))
6624     (or (> (length files) clearcase-dired-max-marked-files-to-check)
6625         (clearcase-utl-every (function clearcase-file-ok-to-hijack)
6626                              files))))
6627
6628 (defun clearcase-dired-marked-ok-to-unhijack ()
6629   (let ((files (dired-get-marked-files)))
6630     (or (> (length files) clearcase-dired-max-marked-files-to-check)
6631         (clearcase-utl-every (function clearcase-file-ok-to-unhijack)
6632                              files))))
6633
6634 (defun clearcase-dired-marked-ok-to-mkelem ()
6635   (let ((files (dired-get-marked-files)))
6636     (or (> (length files) clearcase-dired-max-marked-files-to-check)
6637         (clearcase-utl-every (function clearcase-file-ok-to-mkelem)
6638                              files))))
6639
6640 (defun clearcase-dired-current-dir-ok-to-checkin ()
6641   (let ((dir (dired-current-directory)))
6642     (clearcase-file-ok-to-checkin dir)))
6643
6644 (defun clearcase-dired-current-dir-ok-to-checkout ()
6645   (let ((dir (dired-current-directory)))
6646     (clearcase-file-ok-to-checkout dir)))
6647
6648 (defun clearcase-dired-current-dir-ok-to-uncheckout ()
6649   (let ((dir (dired-current-directory)))
6650     (clearcase-file-ok-to-uncheckout dir)))
6651
6652 ;;}}}
6653
6654 ;;{{{ Contents
6655
6656 ;; This version of the menu will hide rather than grey out inapplicable entries.
6657 ;;
6658 (defvar clearcase-dired-menu-contents-minimised
6659   (list "ClearCase"
6660
6661         ;; Current file
6662         ;;
6663         ["Checkin file" clearcase-checkin-dired-files
6664          :keys nil
6665          :visible (and (< (clearcase-dired-mark-count) 2)
6666                        (clearcase-dired-current-ok-to-checkin))]
6667
6668         ["Edit checkout comment" clearcase-edit-checkout-comment-dired-file
6669          :keys nil
6670          :visible (and (< (clearcase-dired-mark-count) 2)
6671                        (clearcase-dired-current-ok-to-checkin))]
6672
6673         ["Checkout file" clearcase-checkout-dired-files
6674          :keys nil
6675          :visible (and (< (clearcase-dired-mark-count) 2)
6676                        (clearcase-dired-current-ok-to-checkout))]
6677
6678         ["Uncheckout file" clearcase-uncheckout-dired-files
6679          :keys nil
6680          :visible (and (< (clearcase-dired-mark-count) 2)
6681                        (clearcase-dired-current-ok-to-uncheckout))]
6682
6683         ["Hijack file" clearcase-hijack-dired-files
6684          :keys nil
6685          :visible (and (< (clearcase-dired-mark-count) 2)
6686                        (clearcase-dired-current-ok-to-hijack))]
6687
6688         ["Unhijack file" clearcase-unhijack-dired-files
6689          :keys nil
6690          :visible (and (< (clearcase-dired-mark-count) 2)
6691                        (clearcase-dired-current-ok-to-unhijack))]
6692
6693         ["Find checkouts" clearcase-find-checkouts-in-current-view t]
6694
6695         ["Make file an element" clearcase-mkelem-dired-files
6696          :visible (and (< (clearcase-dired-mark-count) 2)
6697                        (clearcase-dired-current-ok-to-mkelem))]
6698
6699         ;; Marked files
6700         ;;
6701         ["Checkin marked files" clearcase-checkin-dired-files
6702          :keys nil
6703          :visible (and (>= (clearcase-dired-mark-count) 2)
6704                        (clearcase-dired-marked-ok-to-checkin))]
6705
6706         ["Checkout marked files" clearcase-checkout-dired-files
6707          :keys nil
6708          :visible (and (>= (clearcase-dired-mark-count) 2)
6709                        (clearcase-dired-marked-ok-to-checkout))]
6710
6711         ["Uncheckout marked files" clearcase-uncheckout-dired-files
6712          :keys nil
6713          :visible (and (>= (clearcase-dired-mark-count) 2)
6714                        (clearcase-dired-marked-ok-to-uncheckout))]
6715
6716         ["Hijack marked files" clearcase-hijack-dired-files
6717          :keys nil
6718          :visible (and (>= (clearcase-dired-mark-count) 2)
6719                        (clearcase-dired-marked-ok-to-hijack))]
6720
6721         ["Unhijack marked files" clearcase-unhijack-dired-files
6722          :keys nil
6723          :visible (and (>= (clearcase-dired-mark-count) 2)
6724                        (clearcase-dired-marked-ok-to-unhijack))]
6725
6726         ["Make marked files elements" clearcase-mkelem-dired-files
6727          :keys nil
6728          :visible (and (>= (clearcase-dired-mark-count) 2)
6729                        (clearcase-dired-marked-ok-to-mkelem))]
6730
6731
6732         ;; Current directory
6733         ;;
6734         ["Checkin current-dir" clearcase-dired-checkin-current-dir
6735          :keys nil
6736          :visible (clearcase-dired-current-dir-ok-to-checkin)]
6737
6738         ["Checkout current dir" clearcase-dired-checkout-current-dir
6739          :keys nil
6740          :visible (clearcase-dired-current-dir-ok-to-checkout)]
6741
6742         ["Uncheckout current dir" clearcase-dired-uncheckout-current-dir
6743          :keys nil
6744          :visible (clearcase-dired-current-dir-ok-to-uncheckout)]
6745
6746         "---------------------------------"
6747         ["Describe file" clearcase-describe-dired-file
6748          :visible t]
6749
6750         ["Annotate file" clearcase-annotate-dired-file
6751          :visible t]
6752
6753         ["Show config-spec rule" clearcase-what-rule-dired-file
6754          :visible t]
6755
6756
6757         ["Edit config-spec" clearcase-edcs-edit t]
6758
6759         "---------------------------------"
6760         (list "Compare (Emacs)..."
6761               ["Compare with predecessor" clearcase-ediff-pred-dired-file
6762                :keys nil
6763                :visible t]
6764               ["Compare with branch base" clearcase-ediff-branch-base-dired-file
6765                :keys nil
6766                :visible t]
6767               ["Compare with named version" clearcase-ediff-named-version-dired-file
6768                :keys nil
6769                :visible t])
6770         (list "Compare (GUI)..."
6771               ["Compare with predecessor" clearcase-gui-diff-pred-dired-file
6772                :keys nil
6773                :visible t]
6774               ["Compare with branch base" clearcase-gui-diff-branch-base-dired-file
6775                :keys nil
6776                :visible t]
6777               ["Compare with named version" clearcase-gui-diff-named-version-dired-file
6778                :keys nil
6779                :visible t])
6780         (list "Compare (diff)..."
6781               ["Compare with predecessor" clearcase-diff-pred-dired-file
6782                :keys nil
6783                :visible t]
6784               ["Compare with branch base" clearcase-diff-branch-base-dired-file
6785                :keys nil
6786                :visible t]
6787               ["Compare with named version" clearcase-diff-named-version-dired-file
6788                :keys nil
6789                :visible t])
6790         "---------------------------------"
6791         ["Browse versions (dired)" clearcase-browse-vtree-dired-file
6792          :visible (clearcase-dired-current-ok-to-browse)]
6793         ["Vtree browser GUI" clearcase-gui-vtree-browser-dired-file
6794          :keys nil
6795          :visible t]
6796         "---------------------------------"
6797         (list "Update snapshot..."
6798               ["Update view" clearcase-update-view
6799                :keys nil
6800                :visible (and (clearcase-file-is-in-view-p default-directory)
6801                              (not (clearcase-file-is-in-mvfs-p default-directory)))]
6802               ["Update directory" clearcase-update-default-directory
6803                :keys nil
6804                :visible (and (clearcase-file-is-in-view-p default-directory)
6805                              (not (clearcase-file-is-in-mvfs-p default-directory)))]
6806               ["Update file" clearcase-update-dired-files
6807                :keys nil
6808                :visible (and (< (clearcase-dired-mark-count) 2)
6809                              (clearcase-dired-current-ok-to-checkout)
6810                              (not (clearcase-file-is-in-mvfs-p default-directory)))]
6811               ["Update marked files" clearcase-update-dired-files
6812                :keys nil
6813                :visible (and (>= (clearcase-dired-mark-count) 2)
6814                              (not (clearcase-file-is-in-mvfs-p default-directory)))]
6815               )
6816         "---------------------------------"
6817         (list "Element history..."
6818               ["Element history (full)" clearcase-list-history-dired-file
6819                :keys nil
6820                :visible t]
6821               ["Element history (branch)" clearcase-list-history-dired-file
6822                :keys nil
6823                :visible t]
6824               ["Element history (me)" clearcase-list-history-dired-file
6825                :keys nil
6826                :visible t])
6827         "---------------------------------"
6828         ["Show current activity" clearcase-ucm-describe-current-activity
6829          :keys nil
6830          :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6831         ["Make activity" clearcase-ucm-mkact-current-dir
6832          :keys nil
6833          :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6834         ["Set activity..." clearcase-ucm-set-activity-current-dir
6835          :keys nil
6836          :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6837         ["Set NO activity" clearcase-ucm-set-activity-none-current-dir
6838          :keys nil
6839          :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6840         ["Rebase this stream" clearcase-gui-rebase
6841          :keys nil
6842          :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6843         ["Deliver from this stream" clearcase-gui-deliver
6844          :keys nil
6845          :visible (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
6846         "---------------------------------"
6847         (list "ClearCase GUI"
6848               ["ClearCase Explorer" clearcase-gui-clearexplorer
6849                :keys nil
6850                :visible clearcase-on-mswindows]
6851               ["Project Explorer" clearcase-gui-project-explorer
6852                :keys nil]
6853               ["Merge Manager" clearcase-gui-merge-manager
6854                :keys nil]
6855               ["Snapshot View Updater" clearcase-gui-snapshot-view-updater
6856                :keys nil])
6857         "---------------------------------"
6858
6859         ["Make branch type" clearcase-mkbrtype
6860          :keys nil]
6861
6862         "---------------------------------"
6863         ["Report Bug in ClearCase Mode" clearcase-submit-bug-report
6864          :keys nil]
6865
6866         ["Dump internals" clearcase-dump
6867          :keys nil
6868          :visible (or (equal "rwhitby" (user-login-name))
6869                       (equal "esler" (user-login-name)))]
6870
6871         ["Flush caches" clearcase-flush-caches
6872          :keys nil
6873          :visible (or (equal "rwhitby" (user-login-name))
6874                       (equal "esler" (user-login-name)))]
6875
6876         "---------------------------------"
6877         ["Customize..." (customize-group 'clearcase)
6878          :keys nil]))
6879
6880 (defvar clearcase-dired-menu-contents
6881   (list "ClearCase"
6882
6883         ;; Current file
6884         ;;
6885         ["Checkin file" clearcase-checkin-dired-files
6886          :keys nil
6887          :active (and (< (clearcase-dired-mark-count) 2)
6888                       (clearcase-dired-current-ok-to-checkin))]
6889
6890         ["Edit checkout comment" clearcase-edit-checkout-comment-dired-file
6891          :keys nil
6892          :active (and (< (clearcase-dired-mark-count) 2)
6893                       (clearcase-dired-current-ok-to-checkin))]
6894
6895         ["Checkout file" clearcase-checkout-dired-files
6896          :keys nil
6897          :active (and (< (clearcase-dired-mark-count) 2)
6898                       (clearcase-dired-current-ok-to-checkout))]
6899
6900         ["Uncheckout file" clearcase-uncheckout-dired-files
6901          :keys nil
6902          :active (and (< (clearcase-dired-mark-count) 2)
6903                       (clearcase-dired-current-ok-to-uncheckout))]
6904
6905         ["Hijack file" clearcase-hijack-dired-files
6906          :keys nil
6907          :active (and (< (clearcase-dired-mark-count) 2)
6908                       (clearcase-dired-current-ok-to-hijack))]
6909
6910         ["Unhijack file" clearcase-unhijack-dired-files
6911          :keys nil
6912          :active (and (< (clearcase-dired-mark-count) 2)
6913                       (clearcase-dired-current-ok-to-unhijack))]
6914
6915         ["Make file an element" clearcase-mkelem-dired-files
6916          :active (and (< (clearcase-dired-mark-count) 2)
6917                       (clearcase-dired-current-ok-to-mkelem))]
6918
6919         ;; Marked files
6920         ;;
6921         ["Checkin marked files" clearcase-checkin-dired-files
6922          :keys nil
6923          :active (and (>= (clearcase-dired-mark-count) 2)
6924                       (clearcase-dired-marked-ok-to-checkin))]
6925
6926         ["Checkout marked files" clearcase-checkout-dired-files
6927          :keys nil
6928          :active (and (>= (clearcase-dired-mark-count) 2)
6929                       (clearcase-dired-marked-ok-to-checkout))]
6930
6931         ["Uncheckout marked files" clearcase-uncheckout-dired-files
6932          :keys nil
6933          :active (and (>= (clearcase-dired-mark-count) 2)
6934                       (clearcase-dired-marked-ok-to-uncheckout))]
6935
6936         ["Hijack marked files" clearcase-hijack-dired-files
6937          :keys nil
6938          :active (and (>= (clearcase-dired-mark-count) 2)
6939                       (clearcase-dired-marked-ok-to-hijack))]
6940
6941         ["Unhijack marked files" clearcase-unhijack-dired-files
6942          :keys nil
6943          :active (and (>= (clearcase-dired-mark-count) 2)
6944                       (clearcase-dired-marked-ok-to-unhijack))]
6945
6946         ["Make marked files elements" clearcase-mkelem-dired-files
6947          :keys nil
6948          :active (and (>= (clearcase-dired-mark-count) 2)
6949                       (clearcase-dired-marked-ok-to-mkelem))]
6950
6951
6952         ;; Current directory
6953         ;;
6954         ["Checkin current-dir" clearcase-dired-checkin-current-dir
6955          :keys nil
6956          :active (clearcase-dired-current-dir-ok-to-checkin)]
6957
6958         ["Checkout current dir" clearcase-dired-checkout-current-dir
6959          :keys nil
6960          :active (clearcase-dired-current-dir-ok-to-checkout)]
6961
6962         ["Uncheckout current dir" clearcase-dired-uncheckout-current-dir
6963          :keys nil
6964          :active (clearcase-dired-current-dir-ok-to-uncheckout)]
6965
6966         "---------------------------------"
6967         ["Describe file" clearcase-describe-dired-file
6968          :active t]
6969
6970         ["Annotate file" clearcase-annotate-dired-file
6971          :active t]
6972
6973         ["Show config-spec rule" clearcase-what-rule-dired-file
6974          :active t]
6975
6976
6977         ["Edit config-spec" clearcase-edcs-edit t]
6978
6979         "---------------------------------"
6980         (list "Compare (Emacs)..."
6981               ["Compare with predecessor" clearcase-ediff-pred-dired-file
6982                :keys nil
6983                :active t]
6984               ["Compare with branch base" clearcase-ediff-branch-base-dired-file
6985                :keys nil
6986                :active t]
6987               ["Compare with named version" clearcase-ediff-named-version-dired-file
6988                :keys nil
6989                :active t])
6990         (list "Compare (GUI)..."
6991               ["Compare with predecessor" clearcase-gui-diff-pred-dired-file
6992                :keys nil
6993                :active t]
6994               ["Compare with branch base" clearcase-gui-diff-branch-base-dired-file
6995                :keys nil
6996                :active t]
6997               ["Compare with named version" clearcase-gui-diff-named-version-dired-file
6998                :keys nil
6999                :active t])
7000         (list "Compare (diff)..."
7001               ["Compare with predecessor" clearcase-diff-pred-dired-file
7002                :keys nil
7003                :active t]
7004               ["Compare with branch base" clearcase-diff-branch-base-dired-file
7005                :keys nil
7006                :active t]
7007               ["Compare with named version" clearcase-diff-named-version-dired-file
7008                :keys nil
7009                :active t])
7010         "---------------------------------"
7011         ["Browse versions (dired)" clearcase-browse-vtree-dired-file
7012          :active (clearcase-dired-current-ok-to-browse)]
7013         ["Vtree browser GUI" clearcase-gui-vtree-browser-dired-file
7014          :keys nil
7015          :active t]
7016         "---------------------------------"
7017         (list "Update snapshot..."
7018               ["Update view" clearcase-update-view
7019                :keys nil
7020                :active (and (clearcase-file-is-in-view-p default-directory)
7021                             (not (clearcase-file-is-in-mvfs-p default-directory)))]
7022               ["Update directory" clearcase-update-default-directory
7023                :keys nil
7024                :active (and (clearcase-file-is-in-view-p default-directory)
7025                             (not (clearcase-file-is-in-mvfs-p default-directory)))]
7026               ["Update file" clearcase-update-dired-files
7027                :keys nil
7028                :active (and (< (clearcase-dired-mark-count) 2)
7029                             (clearcase-dired-current-ok-to-checkout)
7030                             (not (clearcase-file-is-in-mvfs-p default-directory)))]
7031               ["Update marked files" clearcase-update-dired-files
7032                :keys nil
7033                :active (and (>= (clearcase-dired-mark-count) 2)
7034                             (not (clearcase-file-is-in-mvfs-p default-directory)))]
7035               )
7036         "---------------------------------"
7037         (list "Element history..."
7038               ["Element history (full)" clearcase-list-history-dired-file
7039                :keys nil
7040                :active t]
7041               ["Element history (branch)" clearcase-list-history-dired-file
7042                :keys nil
7043                :active t]
7044               ["Element history (me)" clearcase-list-history-dired-file
7045                :keys nil
7046                :active t])
7047         "---------------------------------"
7048         ["Show current activity" clearcase-ucm-describe-current-activity
7049          :keys nil
7050          :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
7051         ["Make activity" clearcase-ucm-mkact-current-dir
7052          :keys nil
7053          :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
7054         ["Set activity..." clearcase-ucm-set-activity-current-dir
7055          :keys nil
7056          :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
7057         ["Set NO activity" clearcase-ucm-set-activity-none-current-dir
7058          :keys nil
7059          :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
7060         ["Rebase this stream" clearcase-gui-rebase
7061          :keys nil
7062          :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
7063         ["Deliver from this stream" clearcase-gui-deliver
7064          :keys nil
7065          :active (clearcase-vprop-ucm (clearcase-fprop-viewtag default-directory))]
7066         "---------------------------------"
7067         (list "ClearCase GUI"
7068               ["ClearCase Explorer" clearcase-gui-clearexplorer
7069                :keys nil
7070                :active clearcase-on-mswindows]
7071               ["Project Explorer" clearcase-gui-project-explorer
7072                :keys nil]
7073               ["Merge Manager" clearcase-gui-merge-manager
7074                :keys nil]
7075               ["Snapshot View Updater" clearcase-gui-snapshot-view-updater
7076                :keys nil])
7077         "---------------------------------"
7078
7079         ["Make branch type" clearcase-mkbrtype
7080          :keys nil]
7081
7082         "---------------------------------"
7083         ["Report Bug in ClearCase Mode" clearcase-submit-bug-report
7084          :keys nil]
7085
7086         ["Dump internals" clearcase-dump
7087          :keys nil
7088          :active (or (equal "rwhitby" (user-login-name))
7089                      (equal "esler" (user-login-name)))]
7090
7091         ["Flush caches" clearcase-flush-caches
7092          :keys nil
7093          :active (or (equal "rwhitby" (user-login-name))
7094                      (equal "esler" (user-login-name)))]
7095
7096         "---------------------------------"
7097         ["Customize..." (customize-group 'clearcase)
7098          :keys nil]))
7099
7100 (if (and clearcase-minimise-menus
7101          (not clearcase-xemacs-p))
7102     (setq clearcase-dired-menu-contents clearcase-dired-menu-contents-minimised))
7103
7104 ;;}}}
7105
7106 (if (>= emacs-major-version '20)
7107     (progn
7108       (easy-menu-define
7109         clearcase-dired-menu
7110         (list clearcase-dired-mode-map)
7111         "ClearCase Dired menu"
7112         clearcase-dired-menu-contents)
7113
7114       (or clearcase-xemacs-p
7115           (add-to-list 'menu-bar-final-items 'ClearCase))))
7116
7117 ;;}}}
7118
7119 ;;}}}
7120
7121 ;;{{{ Widgets
7122
7123 ;;{{{ Single-selection buffer widget
7124
7125 ;; Keep the compiler quiet by declaring these
7126 ;; buffer-local variables here thus.
7127 ;;
7128 (defvar clearcase-selection-window-config nil)
7129 (defvar clearcase-selection-interpreter nil)
7130 (defvar clearcase-selection-continuation nil)
7131 (defvar clearcase-selection-operands nil)
7132
7133 (defun clearcase-ucm-make-selection-window (buffer-name
7134                                             buffer-contents
7135                                             selection-interpreter
7136                                             continuation
7137                                             cont-arglist)
7138   (let ((buf (get-buffer-create buffer-name)))
7139     (save-excursion
7140
7141       ;; Reset the buffer
7142       ;;
7143       (set-buffer buf)
7144       (setq buffer-read-only nil)
7145       (erase-buffer)
7146       (setq truncate-lines t)
7147
7148       ;; Paint the buffer
7149       ;;
7150       (goto-char (point-min))
7151       (insert buffer-contents)
7152
7153       ;; Insert mouse-highlighting
7154       ;;
7155       (save-excursion
7156         (goto-char (point-min))
7157         (while (< (point) (point-max))
7158           (condition-case nil
7159               (progn
7160                 (beginning-of-line)
7161                 (put-text-property (point)
7162                                    (save-excursion
7163                                      (end-of-line)
7164                                      (point))
7165                                    'mouse-face 'highlight))
7166             (error nil))
7167           (forward-line 1)))
7168
7169       ;; Set a keymap
7170       ;;
7171       (setq buffer-read-only t)
7172       (use-local-map clearcase-selection-keymap)
7173
7174       ;; Set up the interpreter and continuation
7175       ;;
7176       (set (make-local-variable 'clearcase-selection-window-config)
7177            (current-window-configuration))
7178       (set (make-local-variable 'clearcase-selection-interpreter)
7179            selection-interpreter)
7180       (set (make-local-variable 'clearcase-selection-continuation)
7181            continuation)
7182       (set (make-local-variable 'clearcase-selection-operands)
7183            cont-arglist))
7184
7185     ;; Display the buffer
7186     ;;
7187     (pop-to-buffer buf)
7188     (goto-char 0)
7189     (shrink-window-if-larger-than-buffer)
7190     (message "Use RETURN to select an item")))
7191
7192 (defun clearcase-selection-continue ()
7193   (interactive)
7194   (beginning-of-line)
7195   (sit-for 0)
7196   ;; Call the interpreter to extract the item of interest
7197   ;; from the buffer.
7198   ;;
7199   (let ((item (funcall clearcase-selection-interpreter)))
7200     ;; Call the continuation.
7201     ;;
7202     (apply clearcase-selection-continuation
7203            (append clearcase-selection-operands (list item))))
7204
7205   ;; Restore window config
7206   ;;
7207   (let ((sel-buffer (current-buffer)))
7208     (if clearcase-selection-window-config
7209         (set-window-configuration clearcase-selection-window-config))
7210     (delete-windows-on sel-buffer)
7211     (kill-buffer sel-buffer)))
7212
7213 (defun clearcase-selection-mouse-continue (click)
7214   (interactive "@e")
7215   (mouse-set-point click)
7216   (clearcase-selection-continue))
7217
7218 (defvar clearcase-selection-keymap
7219   (let ((map (make-sparse-keymap)))
7220     (define-key map [return] 'clearcase-selection-continue)
7221     (define-key map [mouse-2] 'clearcase-selection-mouse-continue)
7222     (define-key map "q" 'clearcase-utl-kill-view-buffer)
7223     ;; nyi: refresh list
7224     ;; (define-key map "g" 'clearcase-selection-get)
7225     map))
7226
7227 ;;}}}
7228
7229 ;;}}}
7230
7231 ;;{{{ Integration with Emacs
7232
7233 ;;{{{ Functions: examining the ClearCase installation
7234
7235 ;; Discover ClearCase version-string
7236 ;;
7237 (defun clearcase-get-version-string ()
7238   ;; Some care seems to be necessary to avoid problems caused by odd settings
7239   ;; of the "SHELL" environment variable.  I found that simply
7240   ;; (shell-command-to-string "cleartool -version") on Windows-2000 with
7241   ;; SHELL==cmd.exe just returned a copy of the Windows command prompt. The
7242   ;; result was that clearcase-integrate would not complete.
7243   ;;
7244   ;; The follow seems to work.
7245   ;;
7246   (if clearcase-on-mswindows
7247       (shell-command-to-string "cmd /c cleartool -version")
7248     (shell-command-to-string "sh -c \"cleartool -version\"")))
7249
7250 ;; Find where cleartool is installed.
7251 ;;
7252 (defun clearcase-find-cleartool ()
7253   "Search directories listed in the PATH environment variable
7254 looking for a cleartool executable. If found return the full pathname."
7255   (let ((dir-list (parse-colon-path (getenv "PATH")))
7256         (cleartool-name (if clearcase-on-mswindows
7257                             "cleartool.exe"
7258                           "cleartool"))
7259         (cleartool-path nil))
7260     (catch 'found
7261       (mapcar
7262        (function (lambda (dir)
7263                    (let ((f (expand-file-name (concat dir cleartool-name))))
7264                      (if (file-executable-p f)
7265                          (progn
7266                            (setq cleartool-path f)
7267                            (throw 'found t))))))
7268        dir-list)
7269       nil)
7270     cleartool-path))
7271
7272 (defun clearcase-non-lt-registry-server-online-p ()
7273   "Heuristic to determine if the local host is network-connected to
7274 its ClearCase servers. Used for a non-LT system."
7275
7276   (let ((result nil)
7277         (buf (get-buffer-create " *clearcase-lsregion*")))
7278     (save-excursion
7279       (set-buffer buf)
7280       (erase-buffer)
7281       (let ((process (start-process "lsregion"
7282                                     buf
7283                                     "cleartool"
7284                                     "lsregion"
7285                                     "-long"))
7286             (timeout-occurred nil))
7287
7288         ;; Now wait a little while, if necessary, for some output.
7289         ;;
7290         (while (and (null result)
7291                     (not timeout-occurred)
7292                     (< (buffer-size) (length "Tag: ")))
7293           (if (null (accept-process-output process 10))
7294               (setq timeout-occurred t))
7295           (goto-char (point-min))
7296           (if (looking-at "Tag: ")
7297               (setq result t)))
7298         (condition-case nil
7299             (kill-process process)
7300           (error nil))))
7301     ;; If servers are apparently not online, keep the
7302     ;; buffer around so we can see what lsregion reported.
7303     ;;
7304     (sit-for 0.01); Fix by AJM to prevent kill-buffer claiming process still running
7305     (if result
7306         (kill-buffer buf))
7307     result))
7308
7309 ;; We could have an LT system, which lacks ct+lsregion, but has ct+lssite.
7310 ;;
7311 (defun clearcase-lt-registry-server-online-p ()
7312   "Heuristic to determine if the local host is network-connected to
7313 its ClearCase servers. Used for LT system."
7314
7315   (let ((result nil)
7316         (buf (get-buffer-create " *clearcase-lssite*")))
7317     (save-excursion
7318       (set-buffer buf)
7319       (erase-buffer)
7320       (let ((process (start-process "lssite"
7321                                     buf
7322                                     "cleartool"
7323                                     "lssite"
7324                                     "-inquire"))
7325             (timeout-occurred nil))
7326
7327         ;; Now wait a little while, if necessary, for some output.
7328         ;;
7329         (while (and (null result)
7330                     (not timeout-occurred)
7331                     (< (buffer-size) (length "  view_cache_size")))
7332           (if (null (accept-process-output process 10))
7333               (setq timeout-occurred t))
7334           (goto-char (point-min))
7335           (if (re-search-forward "view_cache_size" nil t)
7336               (setq result t)))
7337         (condition-case nil
7338             (kill-process process)
7339           (error nil))))
7340
7341     ;; If servers are apparently not online, keep the
7342     ;; buffer around so we can see what lssite reported.
7343     ;;
7344     (sit-for 0.01); Fix by AJM to prevent kill-buffer claiming process still running
7345     (if result
7346         (kill-buffer buf))
7347     result))
7348
7349 ;; Find out if the ClearCase registry server is accessible.
7350 ;; We could be on a disconnected laptop.
7351 ;;
7352 (defun clearcase-registry-server-online-p ()
7353   "Heuristic to determine if the local host is network-connected to
7354 its ClearCase server(s)."
7355
7356   (if clearcase-lt
7357       (clearcase-lt-registry-server-online-p)
7358     (clearcase-non-lt-registry-server-online-p)))
7359
7360 ;;}}}
7361 ;;{{{ Functions: hooks
7362
7363 ;;{{{ A find-file hook to turn on clearcase-mode
7364
7365 (defun clearcase-hook-find-file-hook ()
7366   (let ((filename (buffer-file-name)))
7367     (if filename
7368         (progn
7369           (clearcase-fprop-unstore-properties filename)
7370           (if (clearcase-file-would-be-in-view-p filename)
7371               (progn
7372                 ;; 1. Activate minor mode
7373                 ;;
7374                 (clearcase-mode 1)
7375
7376                 ;; 2. Pre-fetch file properties
7377                 ;;
7378                 (if (file-exists-p filename)
7379                     (progn
7380                       (clearcase-fprop-get-properties filename)
7381
7382                       ;; 3. Put branch/ver in mode-line
7383                       ;;
7384                       (setq clearcase-mode
7385                             (concat " ClearCase:"
7386                                     (clearcase-mode-line-buffer-id filename)))
7387                       (force-mode-line-update)
7388
7389                       ;; 4. Schedule the asynchronous fetching of the view's properties
7390                       ;;    next time Emacs is idle enough.
7391                       ;;
7392                       (clearcase-vprop-schedule-work (clearcase-fprop-viewtag filename))
7393
7394                       ;; 5. Set backup policy
7395                       ;;
7396                       (unless clearcase-make-backup-files
7397                         (make-local-variable 'backup-inhibited)
7398                         (setq backup-inhibited t))))
7399
7400                 (clearcase-set-auto-mode)))))))
7401
7402 (defun clearcase-set-auto-mode ()
7403   "Check again for the mode of the current buffer when using ClearCase version extended paths."
7404
7405   (let* ((version (clearcase-vxpath-version-part (buffer-file-name)))
7406          (buffer-file-name (clearcase-vxpath-element-part (buffer-file-name))))
7407
7408     ;; Need to recheck the major mode only if a version was appended.
7409     ;;
7410     (if version
7411         (set-auto-mode))))
7412
7413 ;;}}}
7414
7415 ;;{{{ A find-file hook for version-extended pathnames
7416
7417 (defun clearcase-hook-vxpath-find-file-hook ()
7418   (if (clearcase-vxpath-p default-directory)
7419       (let ((element (clearcase-vxpath-element-part default-directory))
7420             (version (clearcase-vxpath-version-part default-directory)))
7421
7422         ;; 1. Set the buffer name to <filename>@@/<branch path>/<version>.
7423         ;;
7424         (let ((new-buffer-name
7425                (concat (file-name-nondirectory element)
7426                        clearcase-vxpath-glue
7427                        version
7428                        (buffer-name))))
7429
7430           (or (string= new-buffer-name (buffer-name))
7431
7432               ;; Uniquify the name, if necessary.
7433               ;;
7434               (let ((n 2)
7435                     (uniquifier-string ""))
7436                 (while (get-buffer (concat new-buffer-name uniquifier-string))
7437                   (setq uniquifier-string (format "<%d>" n))
7438                   (setq n (1+ n)))
7439                 (rename-buffer
7440                  (concat new-buffer-name uniquifier-string)))))
7441
7442         ;; 2. Set the default directory to the dir containing <filename>.
7443         ;;
7444         (let ((new-dir (file-name-directory element)))
7445           (setq default-directory new-dir))
7446
7447         ;; 3. Disable auto-saving.
7448         ;;
7449         ;; If we're visiting <filename>@@/<branch path>/199
7450         ;; we don't want Emacs trying to find a place to create a "#199#.
7451         ;;
7452         (auto-save-mode 0))))
7453
7454 ;;}}}
7455
7456 ;;{{{ A dired-mode-hook to turn on clearcase-dired-mode
7457
7458 (defun clearcase-hook-dired-mode-hook ()
7459   ;; Force a re-computation of whether the directory is within ClearCase.
7460   ;;
7461   (clearcase-fprop-unstore-properties default-directory)
7462
7463   ;; Wrap this in an exception handler. Otherwise, diredding into
7464   ;; a deregistered or otherwise defective snapshot-view fails.
7465   ;;
7466   (condition-case nil
7467       ;; If this directory is below a ClearCase element,
7468       ;;   1. turn on ClearCase Dired Minor Mode.
7469       ;;   2. display branch/ver in mode-line
7470       ;;
7471       (if (clearcase-file-would-be-in-view-p default-directory)
7472           (progn
7473             (if clearcase-auto-dired-mode
7474                 (progn
7475                   (clearcase-dired-mode 1)
7476                   (clearcase-fprop-get-properties default-directory)
7477                   (clearcase-vprop-schedule-work (clearcase-fprop-viewtag default-directory))))
7478             (setq clearcase-dired-mode
7479                   (concat " ClearCase:"
7480                           (clearcase-mode-line-buffer-id default-directory)))
7481             (force-mode-line-update)))
7482     (error (message "Error fetching ClearCase properties of %s" default-directory))))
7483
7484 ;;}}}
7485
7486 ;;{{{ A dired-after-readin-hook to add ClearCase information to the display
7487
7488 (defun clearcase-hook-dired-after-readin-hook ()
7489
7490   ;; If in clearcase-dired-mode, reformat the buffer.
7491   ;;
7492   (if clearcase-dired-mode
7493       (progn
7494         (clearcase-dired-reformat-buffer)
7495           (if clearcase-dired-show-view
7496               (clearcase-dired-insert-viewtag))))
7497   t)
7498
7499 ;;}}}
7500
7501 ;;{{{ A write-file-hook to auto-insert a version-string.
7502
7503 ;; To use this, put a line containing this in the first 8 lines of your file:
7504 ;;    ClearCase-version: </main/laptop/155>
7505 ;; and make sure that clearcase-version-stamp-active gets set to true at least
7506 ;; locally in the file.
7507
7508 (defvar clearcase-version-stamp-line-limit 1000)
7509 (defvar clearcase-version-stamp-begin-regexp "ClearCase-version:[ \t]<")
7510 (defvar clearcase-version-stamp-end-regexp ">")
7511 (defvar clearcase-version-stamp-active nil)
7512
7513 (defun clearcase-increment-version (version-string)
7514   (let* ((branch (clearcase-vxpath-branch version-string))
7515          (number (clearcase-vxpath-version version-string))
7516          (new-number (1+ (string-to-number number))))
7517     (format "%s%d" branch new-number)))
7518
7519 (defun clearcase-version-stamp ()
7520   (interactive)
7521   (if (and clearcase-mode
7522            clearcase-version-stamp-active
7523            (file-exists-p buffer-file-name)
7524            (equal 'version (clearcase-fprop-mtype buffer-file-name)))
7525       (let ((latest-version (clearcase-fprop-predecessor-version buffer-file-name)))
7526
7527         ;; Note: If the buffer happens to be folded, we may not find the place
7528         ;; to insert the version-stamp. Folding mode really needs to supply a
7529         ;; 'save-folded-excursion function to solve this one.  We won't attempt
7530         ;; a cheaper hack here.
7531
7532         (save-excursion
7533           (save-restriction
7534             (widen)
7535             (goto-char (point-min))
7536             (forward-line clearcase-version-stamp-line-limit)
7537             (let ((limit (point))
7538                   (v-start nil)
7539                   (v-end nil))
7540               (goto-char (point-min))
7541               (while (and (< (point) limit)
7542                           (re-search-forward clearcase-version-stamp-begin-regexp
7543                                              limit
7544                                              'move))
7545                 (setq v-start (point))
7546                 (end-of-line)
7547                 (let ((line-end (point)))
7548                   (goto-char v-start)
7549                   (if (re-search-forward clearcase-version-stamp-end-regexp
7550                                          line-end
7551                                          'move)
7552                       (setq v-end (match-beginning 0)))))
7553               (if v-end
7554                   (let ((new-version-stamp (clearcase-increment-version latest-version)))
7555                     (goto-char v-start)
7556                     (delete-region v-start v-end)
7557                     (insert-and-inherit new-version-stamp)))))))))
7558
7559 (defun clearcase-hook-write-file-hook ()
7560
7561   (clearcase-version-stamp)
7562   ;; Important to return nil so the files eventually gets written.
7563   ;;
7564   nil)
7565
7566 ;;}}}
7567
7568 ;;{{{ A kill-buffer hook
7569
7570 (defun clearcase-hook-kill-buffer-hook ()
7571   (let ((filename (buffer-file-name)))
7572     (if (and filename
7573              ;; W3 has buffers in which 'buffer-file-name is bound to
7574              ;; a URL.  Don't attempt to unstore their properties.
7575              ;;
7576              (boundp 'buffer-file-truename)
7577              buffer-file-truename)
7578         (clearcase-fprop-unstore-properties filename))))
7579
7580 ;;}}}
7581
7582 ;;{{{ A kill-emacs-hook
7583
7584 (defun clearcase-hook-kill-emacs-hook ()
7585   (clearcase-utl-clean-tempfiles))
7586
7587 ;;}}}
7588
7589 ;;}}}
7590 ;;{{{ Function:  to replace toggle-read-only
7591
7592 (defun clearcase-toggle-read-only (&optional arg)
7593   "Change read-only status of current buffer, perhaps via version control.
7594 If the buffer is visiting a ClearCase version, then check the file in or out.
7595 Otherwise, just change the read-only flag of the buffer.  If called with an
7596 argument then just change the read-only flag even if visiting a ClearCase
7597 version."
7598   (interactive "P")
7599   (cond (arg
7600          (toggle-read-only))
7601         ((and (clearcase-fprop-mtype buffer-file-name)
7602               buffer-read-only
7603               (file-writable-p buffer-file-name)
7604               (/= 0 (user-uid)))
7605          (toggle-read-only))
7606
7607         ((clearcase-fprop-mtype buffer-file-name)
7608          (clearcase-next-action-current-buffer))
7609
7610         (t
7611          (toggle-read-only))))
7612
7613 ;;}}}
7614 ;;{{{ Functions: file-name-handlers
7615
7616 ;;{{{ Start dynamic views automatically when paths to them are used
7617
7618 ;; This handler starts views when viewroot-relative paths are dereferenced.
7619 ;;
7620 ;; nyi: for now really only seems useful on Unix.
7621 ;;
7622 (defun clearcase-viewroot-relative-file-name-handler (operation &rest args)
7623
7624   (clearcase-when-debugging
7625    (if (fboundp 'clearcase-utl-syslog)
7626        (clearcase-utl-syslog "*clearcase-fh-trace*"
7627                              (cons "clearcase-viewroot-relative-file-name-handler:"
7628                                    (cons operation args)))))
7629
7630   ;; Inhibit the handler to avoid recursion.
7631   ;;
7632   (let ((inhibit-file-name-handlers
7633          (cons 'clearcase-viewroot-relative-file-name-handler
7634                (and (eq inhibit-file-name-operation operation)
7635                     inhibit-file-name-handlers)))
7636         (inhibit-file-name-operation operation))
7637
7638     (let ((first-arg (car args)))
7639       ;; We don't always get called with a string.
7640       ;; e.g. one file operation is verify-visited-file-modtime, whose
7641       ;; first argument is a buffer.
7642       ;;
7643       (if (stringp first-arg)
7644           (progn
7645             ;; Now start the view if necessary
7646             ;;
7647             (save-match-data
7648               (let* ((path (clearcase-path-remove-useless-viewtags first-arg))
7649                      (viewtag (clearcase-vrpath-viewtag path))
7650                      (default-directory (clearcase-path-remove-useless-viewtags default-directory)))
7651                 (if viewtag
7652                     (clearcase-viewtag-try-to-start-view viewtag))))))
7653       (apply operation args))))
7654
7655 ;;}}}
7656
7657 ;;{{{ Completion on viewtags
7658
7659 ;; This handler provides completion for viewtags.
7660 ;;
7661 (defun clearcase-viewtag-file-name-handler (operation &rest args)
7662
7663   (clearcase-when-debugging
7664    (if (fboundp 'clearcase-utl-syslog)
7665        (clearcase-utl-syslog "*clearcase-fh-trace*"
7666                              (cons "clearcase-viewtag-file-name-handler:"
7667                                    (cons operation args)))))
7668   (cond
7669
7670    ((eq operation 'file-name-completion)
7671     (save-match-data (apply 'clearcase-viewtag-completion args)))
7672
7673    ((eq operation 'file-name-all-completions)
7674     (save-match-data (apply 'clearcase-viewtag-completions args)))
7675
7676    (t
7677     (let ((inhibit-file-name-handlers
7678            (cons 'clearcase-viewtag-file-name-handler
7679                  (and (eq inhibit-file-name-operation operation)
7680                       inhibit-file-name-handlers)))
7681           (inhibit-file-name-operation operation))
7682       (apply operation args)))))
7683
7684 (defun clearcase-viewtag-completion (file dir)
7685   (try-completion file (clearcase-viewtag-all-viewtag-dirs-obarray)))
7686
7687 (defun clearcase-viewtag-completions (file dir)
7688   (let ((tags (all-completions file
7689                                (clearcase-viewtag-all-viewtags-obarray))))
7690     (mapcar
7691      (function (lambda (tag)
7692                  (concat tag "/")))
7693      tags)))
7694
7695 ;;}}}
7696
7697 ;;{{{ File name handler for version extended file names
7698
7699 ;; For version extended pathnames there are two possible answers
7700 ;; for each of
7701 ;;   file-name-directory
7702 ;;   file-name-nondirectory
7703 ;;
7704 ;; 1. that pertaining to the element path, e.g.
7705 ;;   (file-name-directory "DIR/FILE@@/BRANCH/VERSION")
7706 ;;     ==> "DIR/"
7707 ;; 2. that pertaining to the version path, e.g.
7708 ;;   (file-name-directory "DIR/FILE@@/BRANCH/VERSION")
7709 ;;     ==> "DIR/FILE@@/BRANCH/"
7710 ;;
7711 ;; Often we'd like the former, but sometimes we'd like the latter, for example
7712 ;; inside clearcase-browse-vtree, where it calls dired.  Within dired on Gnu
7713 ;; Emacs, it calls file-name-directory on the supplied pathname and in this
7714 ;; case we want the version (i.e. branch) path to be used.
7715 ;;
7716 ;; How to get the behaviour we want ?
7717
7718 ;; APPROACH A:
7719 ;; ==========
7720 ;;
7721 ;; Define a variable clearcase-treat-branches-as-dirs, which modifies
7722 ;; the behaviour of clearcase-vxpath-file-name-handler to give answer (1).
7723 ;;
7724 ;; Just before we invoke dired inside clearcase-browse-vtree, dynamically
7725 ;; bind clearcase-treat-branches-as-dirs to t. Also in the resulting Dired Mode
7726 ;; buffer, make clearcase-treat-branches-as-dirs buffer-local and set it.
7727 ;;
7728 ;; Unfortunately this doesn't quite give us what we want. For example I often
7729 ;; invoke grep from a dired buffer on a branch-qua-directory to scan all the
7730 ;; version on that branch for a certain string.  The grep-mode buffer has no
7731 ;; buffer-local binding for clearcase-treat-branches-as-dirs so the grep
7732 ;; command runs in "DIR/" instead of in "DIR/FILE@@/BRANCH/".
7733 ;;
7734 ;; APPROACH B:
7735 ;; ==========
7736 ;;
7737 ;; Modify the semantics of clearcase-vxpath-file-name-handler so that
7738 ;; if the filename given is a pathname to an existing branch-qua-directory
7739 ;; give answer 2, otherwise give answer 1.
7740 ;;
7741 ;; APPROACH C:
7742 ;; ==========
7743 ;;
7744 ;; Use the existence of a Dired Mode buffer on "DIR/FILE@@/BRANCH/" to
7745 ;; change the semantics of clearcase-vxpath-file-name-handler.
7746 ;;
7747 ;; (A) is unsatisfactory and I'm not entirely happy with (B) nor (C) so for now
7748 ;; I'm going to disable this filename handler until I'm more convinced it is
7749 ;; needed.
7750
7751 (defun clearcase-vxpath-file-name-handler (operation &rest args)
7752   (clearcase-when-debugging
7753    (if (fboundp 'clearcase-utl-syslog)
7754        (clearcase-utl-syslog "*clearcase-fh-trace*"
7755                              (cons "clearcase-vxpath-file-name-handler:"
7756                                    (cons operation args)))))
7757   ;; Inhibit recursion:
7758   ;;
7759   (let ((inhibit-file-name-handlers
7760          (cons 'clearcase-vxpath-file-name-handler
7761                (and (eq inhibit-file-name-operation operation)
7762                     inhibit-file-name-handlers)))
7763         (inhibit-file-name-operation operation))
7764
7765     (cond ((eq operation 'file-name-nondirectory)
7766            (file-name-nondirectory (clearcase-vxpath-element-part
7767                                     (car args))))
7768
7769           ((eq operation 'file-name-directory)
7770            (file-name-directory (clearcase-vxpath-element-part
7771                                  (car args))))
7772
7773           (t
7774            (apply operation args)))))
7775
7776 ;;}}}
7777
7778 ;;}}}
7779 ;;{{{ Advice: Disable VC in the MVFS
7780
7781 ;; This handler ensures that VC doesn't attempt to operate inside the MVFS.
7782 ;; This stops it from futile searches for RCS directories and the like inside.
7783 ;; It prevents a certain amount of clutter in the MVFS' noent-cache.
7784 ;;
7785
7786 (defadvice vc-registered (around clearcase-interceptor disable compile)
7787   "Disable normal behavior if in a clearcase dynamic view.
7788 This is enabled/disabled by clearcase-integrate/clearcase-unintegrate."
7789   (if (clearcase-file-would-be-in-view-p (ad-get-arg 0))
7790       nil
7791     ad-do-it))
7792
7793 ;;}}}
7794
7795 ;;{{{ Functions: integrate and un-integrate.
7796
7797 (defun clearcase-integrate ()
7798   "Enable ClearCase integration"
7799   (interactive)
7800
7801   ;; 0. Empty caches.
7802   ;;
7803   (clearcase-fprop-clear-all-properties)
7804   (clearcase-vprop-clear-all-properties)
7805
7806   ;; 1. Install hooks.
7807   ;;
7808   (add-hook 'find-file-hooks 'clearcase-hook-find-file-hook)
7809   (add-hook 'find-file-hooks 'clearcase-hook-vxpath-find-file-hook)
7810   (add-hook 'dired-mode-hook 'clearcase-hook-dired-mode-hook)
7811   (add-hook 'dired-after-readin-hook 'clearcase-hook-dired-after-readin-hook)
7812   (add-hook 'kill-buffer-hook 'clearcase-hook-kill-buffer-hook)
7813   (add-hook 'write-file-hooks 'clearcase-hook-write-file-hook)
7814   (add-hook 'kill-emacs-hook 'clearcase-hook-kill-emacs-hook)
7815
7816   ;; 2. Install file-name handlers.
7817   ;;
7818   ;;    2.1 Start views when //view/TAG or m:/TAG is referenced.
7819   ;;
7820   (add-to-list 'file-name-handler-alist
7821                (cons clearcase-vrpath-regexp
7822                      'clearcase-viewroot-relative-file-name-handler))
7823
7824   ;;    2.2 Completion on viewtags.
7825   ;;
7826   (if clearcase-complete-viewtags
7827       (add-to-list 'file-name-handler-alist
7828                    (cons clearcase-viewtag-regexp
7829                          'clearcase-viewtag-file-name-handler)))
7830
7831   ;;    2.3 Turn off RCS/VCS/SCCS activity inside a ClearCase dynamic view.
7832   ;;
7833   (if clearcase-suppress-vc-within-mvfs
7834       (when clearcase-suppress-vc-within-mvfs
7835         (ad-enable-advice 'vc-registered 'around 'clearcase-interceptor)
7836         (ad-activate 'vc-registered)))
7837
7838   ;; Disabled for now. See comments above clearcase-vxpath-file-name-handler.
7839   ;;
7840   ;;   ;;    2.4 Add file name handler for version extended path names
7841   ;;   ;;
7842   ;;   (add-to-list 'file-name-handler-alist
7843   ;;                (cons clearcase-vxpath-glue 'clearcase-vxpath-file-name-handler))
7844   )
7845
7846 (defun clearcase-unintegrate ()
7847   "Disable ClearCase integration"
7848   (interactive)
7849
7850   ;; 0. Empty caches.
7851   ;;
7852   (clearcase-fprop-clear-all-properties)
7853   (clearcase-vprop-clear-all-properties)
7854
7855   ;; 1. Remove hooks.
7856   ;;
7857   (remove-hook 'find-file-hooks 'clearcase-hook-find-file-hook)
7858   (remove-hook 'find-file-hooks 'clearcase-hook-vxpath-find-file-hook)
7859   (remove-hook 'dired-mode-hook 'clearcase-hook-dired-mode-hook)
7860   (remove-hook 'dired-after-readin-hook 'clearcase-hook-dired-after-readin-hook)
7861   (remove-hook 'kill-buffer-hook 'clearcase-hook-kill-buffer-hook)
7862   (remove-hook 'write-file-hooks 'clearcase-hook-write-file-hook)
7863   (remove-hook 'kill-emacs-hook 'clearcase-hook-kill-emacs-hook)
7864
7865   ;; 2. Remove file-name handlers.
7866   ;;
7867   (setq file-name-handler-alist
7868         (delete-if (function
7869                     (lambda (entry)
7870                       (memq (cdr entry)
7871                             '(clearcase-viewroot-relative-file-name-handler
7872                               clearcase-viewtag-file-name-handler
7873                               clearcase-vxpath-file-name-handler))))
7874                    file-name-handler-alist))
7875
7876   ;; 3. Turn on RCS/VCS/SCCS activity everywhere.
7877   ;;
7878   (ad-disable-advice 'vc-registered 'around 'clearcase-interceptor)
7879   (ad-activate 'vc-registered))
7880
7881 ;;}}}
7882
7883 ;; Here's where we really wire it all in:
7884 ;;
7885 (defvar clearcase-cleartool-path nil)
7886 (defvar clearcase-clearcase-version-installed nil)
7887 (defvar clearcase-lt nil)
7888 (defvar clearcase-v3 nil)
7889 (defvar clearcase-v4 nil)
7890 (defvar clearcase-v6 nil)
7891 (defvar clearcase-servers-online nil)
7892 (defvar clearcase-setview-root nil)
7893 (defvar clearcase-setview-viewtag)
7894 (defvar clearcase-setview-root nil)
7895 (defvar clearcase-setview-viewtag nil)
7896
7897 (progn
7898   ;; If the SHELL environment variable points to the wrong place,
7899   ;; call-process fails on Windows and this startup fails.
7900   ;; Check for this and unset the useless EV.
7901
7902   (let ((shell-ev-value (getenv "SHELL")))
7903     (if clearcase-on-mswindows
7904         (if (stringp shell-ev-value)
7905             (if (not (executable-find shell-ev-value))
7906                 (setenv "SHELL" nil)))))
7907
7908   ;; Things have to be done here in a certain order.
7909   ;;
7910   ;; 1. Make sure cleartool is on the shell search PATH.
7911   ;;
7912   (if (setq clearcase-cleartool-path (clearcase-find-cleartool))
7913       (progn
7914         ;; 2. Try to discover what version of ClearCase we have:
7915         ;;
7916         (setq clearcase-clearcase-version-installed (clearcase-get-version-string))
7917         (setq clearcase-lt
7918               (not (null (string-match "ClearCase LT"
7919                                        clearcase-clearcase-version-installed))))
7920         (setq clearcase-v3
7921               (not (null (string-match "^ClearCase version 3"
7922                                        clearcase-clearcase-version-installed))))
7923         (setq clearcase-v4
7924               (not (null (string-match "^ClearCase version 4"
7925                                        clearcase-clearcase-version-installed))))
7926         (setq clearcase-v5
7927               (not (null (string-match "^ClearCase \\(LT \\)?version 2002.05"
7928                                        clearcase-clearcase-version-installed))))
7929         (setq clearcase-v6
7930               (not (null (string-match "^ClearCase \\(LT \\)?version 2003.06"
7931                                        clearcase-clearcase-version-installed))))
7932
7933         ;; 3. Gather setview information:
7934         ;;
7935         (if (setq clearcase-setview-root (if (not clearcase-on-mswindows)
7936                                              (getenv "CLEARCASE_ROOT")))
7937             (setq clearcase-setview-viewtag
7938                   (file-name-nondirectory clearcase-setview-root)))
7939
7940         ;; 4. Discover if the servers appear to be online.
7941         ;;
7942         (setq clearcase-servers-online (clearcase-registry-server-online-p))
7943
7944         (if clearcase-servers-online
7945
7946             ;; 5. Everything seems in place to ensure that ClearCase mode will
7947             ;;    operate correctly, so integrate now.
7948             ;;
7949             (progn
7950               (clearcase-integrate)
7951               ;; Schedule a fetching of the view properties when next idle.
7952               ;; This avoids awkward pauses after the user reaches for the
7953               ;; ClearCase menubar entry.
7954               ;;
7955               (if clearcase-setview-viewtag
7956                   (clearcase-vprop-schedule-work clearcase-setview-viewtag)))))))
7957
7958 (if (not clearcase-servers-online)
7959     (message "ClearCase apparently not online. ClearCase/Emacs integration not installed."))
7960
7961 ;;}}}
7962
7963 (provide 'clearcase)
7964
7965 ;;; clearcase.el ends here
7966 \f
7967 ;; Local variables:
7968 ;; folded-file: t
7969 ;; clearcase-version-stamp-active: t
7970 ;; End: