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