p4-view.el #3

;;; p4-view.el --- Major mode for editing client/branc view specifications

;; Author: Paul Du Bois <dubois@geoworks.com>
;; Maintainer: dubois@infinite-machine.com
;; $Id: //depot/tools/lisp/p4-view.el#7 $

;;; Commentary:

;; A small major mode for editing client and branch views.
;; Adds font-locking, and 
;; When Perforce brings up a client/branch view, the buffer will be
;; automatically put in p4-view-mode.  Use C-c C-c to toggle it into and out
;; of a more human-readable state.

;;; Code:

(defcustom p4-view-auto-compress t
  "* If non-nil, automatically execute p4-view-toggle-compress
when a temp file that looks like a perforce branch or client view
is detected."
  :group 'p4
  :type 'boolean)

(defvar p4v-before-uncompress-hook nil
  "Hook run before view is uncompressed")
(defvar p4v-after-compress-hook nil
  "Hook run after view is compressed")

;;; ----------------------------------------------------------------------
;;; Internal variables
;;; ----------------------------------------------------------------------

;; quiet compiler warnings
(eval-when-compile
  (defvar map nil)
  (defvar font-lock-mode nil))

(defconst p4v-var-re ":\\(src\\|dst\\)\\(\\sw*\\)")

(defvar p4-view-mode-map nil)
(if p4-view-mode-map nil
  (let ((map (make-sparse-keymap)))
    (define-key map "\C-c\C-c" 'p4-view-toggle-compress)
    (setq p4-view-mode-map map)))

(defvar p4-view-font-lock-keywords
  '(
    ("^# \\(NOTE.*\\)" 1 'p4-highlight-face t)
    ("^[A-Za-z]+:" 0 font-lock-reference-face)
    ("^\\s-+\\(-\\)" 1 'p4-highlight-face)
    ;(":[sd=]..\\(\\sw+\\)" (1 font-lock-reference-face))
    (":\\(src\\|bran \\)\\sw*/\\(.*\\)$" (1 font-lock-function-name-face))
    (":\\(dst\\|base \\)\\sw*/\\(.*\\)$" (1 font-lock-keyword-face))
    (":===\\sw*/\\(.*\\)$" (1 font-lock-type-face))
    ("/" (0 'default t))
    ))

;; Seems we need this to get comment hilighting to work.  Whatever.
(defvar p4-view-mode-syntax-table nil
  "Syntax table in use in view-mode buffers.")
(if p4-view-mode-syntax-table
    ()
  (setq p4-view-mode-syntax-table (make-syntax-table (standard-syntax-table)))
  (modify-syntax-entry ?\n ">" p4-view-mode-syntax-table)
  (modify-syntax-entry ?# "<" p4-view-mode-syntax-table))

(defun p4-view-mode ()
  "Major mode for manipulating client and branch views.

Use \\[p4-view-toggle-compress] to make a client/branch mapping
view easier to read and edit.  This examines the view's Description
field and parses lines that look like the following:

 <MAP> //depot/public/project //my_client/project
 <MAP> some_tag //depot/tools/jam //my_client/jam

These lines are used by `p4-view-toggle-compress' to toggle into
and out of a more readable state."
  ;(interactive)
  (kill-all-local-variables)
  (set-syntax-table p4-view-mode-syntax-table)
  (set (make-local-variable 'comment-start-skip) "^#")
  (use-local-map p4-view-mode-map)
  (setq major-mode 'p4-view-mode)
  (setq mode-name "P4-view")
  (set (make-local-variable 'font-lock-defaults)
       '(p4-view-font-lock-keywords nil nil nil))
  (require 'font-lock)	;; because we use font-lock-verbose
  (let ((font-lock-verbose nil))
    (turn-on-font-lock))
  (add-hook 'write-contents-hooks
	    (lambda () (condition-case nil (p4-view-uncompress) (error nil)) nil))
  (make-local-hook 'after-save-hook)
  (add-hook 'after-save-hook
	    (lambda () (condition-case nil (p4-view-compress) (error nil))))
  (if p4-view-auto-compress (p4-view-toggle-compress))
  (p4-view-insert-help-text)
  (message (substitute-command-keys
	    "Use \\[p4-view-toggle-compress] to toggle the view display.")))

(defun p4-view-insert-help-text ()
  ;; Insert some helpful text at the top of the buffer
  (save-excursion
    (goto-char (point-min))
    (while (and (not (eobp)) (looking-at "^#")) (forward-line 1))
    (or (bolp) (insert "\n"))
    (insert "#\n# NOTE: This buffer is in P4-view mode\n")
    (insert "# " (format "%s"
			 (substitute-command-keys
			  "\\[p4-view-toggle-compress] to toggle the view display.\n")))
    (set-buffer-modified-p nil)))
    
(defun p4-view-toggle-compress ()
  "See documentation for `p4-view-mode'."
  (interactive)
  (save-excursion
    (goto-char (point-min))
    (re-search-forward "^View")
    (let ((case-fold-search nil))
      (if (re-search-forward (concat p4v-var-re "\\|:===") nil t)
	  (p4-view-uncompress)
	(p4-view-compress)))))

;;; ----------------------------------------------------------------------
;;; Utils
;;; ----------------------------------------------------------------------

(defmacro p4v-in-view (&rest forms)
  `(save-excursion
     (save-match-data
       (goto-char (point-min))
       (re-search-forward "^View")
       (forward-line 1)
       ,@forms)))
(put 'p4v-in-view 'lisp-indent-function 0)

(defun p4-view-compress ()
  (let* ((old-font-lock-mode (and (boundp 'font-lock-mode) font-lock-mode))
	 (old-mod (buffer-modified-p))
	 (map (p4v-get-map))
	 src dest)
    (and (featurep 'font-lock) (font-lock-mode -1))

    ;; Not really compression, but nice anyway
    (p4v-in-view
      (while (re-search-forward "^\t-" nil t) (replace-match "       -")))

    (while map
      (p4v-in-view
	(setq src (elt map 0) dest (elt map 1)
	      map (nthcdr 2 map))
	;; Replace variables, and replace intervening space with newline
	(while (re-search-forward
		(concat (cdr src) "\\(.*\\) \\(.*\\)" (cdr dest)) nil t)
	  (replace-match
	   (concat (car src) (match-string 1) "\n\t"
		   (match-string 2) (car dest)) t t))))

    (p4v-in-view
      ;; Replace trivial mappings
      (while (re-search-forward p4v-var-re nil t)
	(if (p4-vc-maps-are-equal)
	    (progn
	      (delete-region (progn (end-of-line) (point))
			     (progn (end-of-line 2) (point)))
	      (beginning-of-line)
	      (search-forward ":src") (replace-match ":===")))))

    ;;(p4v-in-view (run-hooks 'p4v-after-compress-hook))

    (if (not old-mod)
	(set-buffer-modified-p nil))
    (if old-font-lock-mode
	(let ((font-lock-verbose nil)) (turn-on-font-lock)))))

;; dynamic scope for `map'
(defun p4v-expand-var ()
  (beginning-of-line)
  (if (re-search-forward p4v-var-re (save-excursion (end-of-line) (point)) t)
      (let* ((var (format "%s" (match-string 0)))
	     (expansion (assoc var map)))
	(replace-match (cdr expansion))))
  (beginning-of-line))

(defun p4-view-uncompress ()
  (let* ((case-fold-search nil)
	 (old-font-lock-mode (and (boundp 'font-lock-mode) font-lock-mode))
	 (map (p4v-get-map))
	 src dest)
    (and (featurep 'font-lock) (font-lock-mode -1))

    ;; expand trivial mappings by duplicating line
    ;;(p4v-in-view (run-hooks 'p4v-before-uncompress-hook))
    (p4v-in-view
      (while (re-search-forward ":===" nil t)
	(replace-match ":src")
	(beginning-of-line)
	(let ((tmp (buffer-substring (point) (progn (end-of-line) (point)))))
	  ;; Remove leading -, replace src with dst
	  (if (string-match "^\\s-*\\(-\\)" tmp)
	      (setq tmp (replace-match "" t t tmp 1)))
	  (if (string-match ":src" tmp)
	      (setq tmp (replace-match ":dst" t t tmp 0)))
	  (forward-line 1) (insert tmp "\n"))))

    ;; Now loop through and expand vars
    (p4v-in-view
      (while (re-search-forward p4v-var-re nil 'move)
	(p4v-expand-var)
	(end-of-line) (delete-char 1) (just-one-space)
	(p4v-expand-var)))

    (if old-font-lock-mode
	(let ((font-lock-verbose nil)) (turn-on-font-lock)))))

(defun p4-vc-maps-are-equal ()
  ;; return true if current and next line are identical except for :src/:dst
  (let (line1 line2)
    (save-excursion
      (beginning-of-line)
      (setq line1 (buffer-substring (point) (progn (end-of-line) (point))))
      (forward-line 1)
      (setq line2 (buffer-substring (point) (progn (end-of-line) (point))))
      ;; Chop leading ws and `-' char
      (if (string-match "^\\s-+-?" line1)
	  (setq line1 (replace-match "" t t line1 0)))
      (if (string-match ":src" line1)
	  (setq line1 (replace-match "&&&" t t line1)))
      (if (string-match "^\\s-+-?" line2)
	  (setq line2 (replace-match "" t t line2 0)))
      (if (string-match ":dst" line2)
	  (setq line2 (replace-match "&&&" t t line2)))
      (string-equal line1 line2))))

(defun p4v-get-map (&optional recursing)
  ;; Return alist mapping vars to expansions
  ;; The alist will always be of the form
  ;; ( (":srcXXX" . <str>) (":dstXXX" . <str>) ... )
  ;; Later <MAP> lines come earlier in the list, to give them higher
  ;; precedence.
  ;;
  ;; Will create a <MAP> line if none exists
  (let (map-alist (i 1))
    (save-match-data
      (save-excursion
	(goto-char (point-min))
	(while (re-search-forward "<MAP> \\(.*\\)" nil 'move)
	  (let ((elts (split-string (format "%s" (match-string 1))))
		varname src dest)
	    ;; no var name given -- push one on the list
	    (if (= (length elts) 2)
		(setq elts (cons (format "%s" (if (= i 1) "" i)) elts)
		      i (1+ i)))
	    (setq varname (elt elts 0)
		  src (elt elts 1)
		  dest (elt elts 2))
	    (setq map-alist
		  (nconc (list (cons (concat ":src" varname) src)
			       (cons (concat ":dst" varname) dest))
			 map-alist))))))

    (if (or recursing map-alist)
	map-alist
      (let ((infer (p4v-infer-map)))
	;; Save off the MAP line by stuffing it in the Description
	(goto-char (point-min))
	(re-search-forward "^Description:") (beginning-of-line)
	(while (not (looking-at "^\\s-*$")) (forward-line 1))
	(insert "\t<MAP> AUTO " (car infer) " " (cdr infer) "\n")
	(p4v-get-map 'recursing)))))

;; Use the first line of the view to infer a mapping.  If the src and dest
;; have one or more tail elements in common, we use the preceding elements
;; to form the general mapping rule.  Clever!
(defun p4v-infer-map ()
  ;; Find the first view line
  (p4v-in-view
    (or (looking-at "\t//\\([^/]+/.*\\) //\\(.*\\)")
	(error "Malformed view"))

    ;; Split it up and find common tail elements
    (let* ((have-common-tail nil)
	   (src (save-match-data
		  (split-string (match-string-no-properties 1) "/")))
	   (dest (save-match-data
		   (split-string (match-string-no-properties 2) "/")))
	   (depot-name (car src))
	   (client-name (car dest)))
      (setq src (nreverse (cdr src))
	    dest (nreverse (cdr dest)))
      (while (and (car src)
		  (equal (car src) (car dest)))
	(setq have-common-tail t
	      src (cdr src)
	      dest (cdr dest)))
      (or have-common-tail (error "Can't figure out mapping"))

      ;; ... use the rest as the src/dest mapping
      (setq src  (concat "//" (mapconcat 'identity (cons depot-name  (nreverse src)) "/"))
	    dest (concat "//" (mapconcat 'identity (cons client-name (nreverse dest)) "/")))
      (cons src dest))))

;;; ----------------------------------------------------------------------
;;; for branch overlays
;;; ----------------------------------------------------------------------

(defun p4v-compress-branch-overlays ()
  ;; Convert:
  ;;   :===b/Foo/Src/...
  ;;   :srcM/Foo/Src/...
  ;;   :dstM/Foo/SrcOrig/...
  ;; To:
  ;;   :bran b/Foo/Src/...
  ;;   :base M/Foo/SrcOrig/...
  ;;
  ;; This pattern comes up when b is from a branch and M is from the
  ;; mainline, and a piece of the tree is being overridden by the branch,
  ;; with the mainline being put in a renamed directory.
  (let (mapname tail)
    (while (re-search-forward "^\\s-+:src\\([^/]*\\)\\(/.*\\)$" nil 'move)
      (setq mapname (match-string-no-properties 1)
	    tail (match-string-no-properties 2))
      (forward-line -1)
      (if (not (looking-at (format "^\\s-+\\(:===\\)[^/]*%s" (regexp-quote tail))))
	  (progn (forward-line 1) (end-of-line))
	(replace-match ":bran " t t nil 1)
	(forward-line 1)
	(delete-region (point) (progn (forward-line 1) (point)))
	(if (not (looking-at (format "^\\s-+\\(:dst\\)%s" (regexp-quote mapname))))
	    (error "Didn't find :dst after :src"))
	(replace-match ":base " t t nil 1)
	))))

(defun p4v-uncompress-branch-overlays ()
  ;; Undoes what was done in prv-compress-branch-overlays
  (while (re-search-forward "^\\s-+:bran \\([^/]*\\)\\(.*\\)\n\\s-+:base \\([^/]*\\)\\(.*\\)" nil 'move)
    (let ((branchmap (match-string-no-properties 1))
	  (tail1 (match-string-no-properties 2))
	  (basemap (match-string-no-properties 3))
	  (tail2 (match-string-no-properties 4)))
      (replace-match
       (format "\t:===%s%s\n\t:src%s%s\n\t:dst%s%s"
	       branchmap tail1
	       basemap tail1
	       basemap tail2)))))

(provide 'p4-view)