;;; p4-protect.el --- Make "p4 protect" views easier to read and modify

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

;;; Commentary:

;; When Perforce brings up a protection view, the buffer is automatically
;; put in p4-protect-mode.  Use C-c C-c to toggle it into and out of a more
;; human-readable state.

;; There are no user entry points; p4-protect-mode is run from
;; a hook set up in p4.el

;;; Code:

(require 'p4)

(defcustom p4-protect-auto-compress nil
  "* If non-nil, automatically compress `p4 protect' specifications."
  :group 'p4
  :type 'boolean)

;;; ----------------------------------------------------------------------
;;; Internal variables, faces, etc.
;;; ----------------------------------------------------------------------

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

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

(defface p4p-no-permission-face
  '((((class color) (background light)) (:foreground "Red" :bold t))
    (((class color) (background dark)) (:foreground "Pink" :bold t))
    (t (:inverse-video t :bold t)))
  "P4 Protect mode face used for permissions being removed."
  :group 'p4-faces)

(defface p4p-lower-permission-face
  '((((class color) (background light)) (:foreground "Red" :bold t))
    (((class color) (background dark)) (:foreground "Pink" :bold t))
    (t (:inverse-video t :bold t)))
  "P4 Protect mode face used for permissions being lowered."
  :group 'p4-faces)

(defface p4p-permission-face
  '((((class grayscale) (background light)) (:foreground "LightGray" :bold t))
    (((class grayscale) (background dark)) (:foreground "DimGray" :bold t))
    (((class color) (background light)) (:foreground "Purple"))
    (((class color) (background dark)) (:foreground "Cyan"))
    (t (:bold t)))
  "P4 Protect mode face used for permissions being added."
  :group 'p4-faces)

(defface p4p-user-name-face
  '((((class grayscale) (background light)) (:foreground "Gray90" :bold t))
    (((class grayscale) (background dark)) (:foreground "DimGray" :bold t))
    (((class color) (background light)) (:foreground "ForestGreen"))
    (((class color) (background dark)) (:foreground "PaleGreen"))
    (t (:bold t :underline t)))
  "P4 Protect mode face used to highlight user names."
  :group 'p4-faces)

(defface p4p-group-name-face
  '((((class grayscale) (background light)) (:foreground "DimGray" :italic t))
    (((class grayscale) (background dark)) (:foreground "LightGray" :italic t))
    (((class color) (background light)) (:foreground "RosyBrown"))
    (((class color) (background dark)) (:foreground "LightSalmon"))
    (t (:italic t)))
  "P4 Protect mode face used to highlight group names."
  :group 'p4-faces)

(defvar p4-protect-font-lock-keywords
  '(
    ("^# \\(NOTE.*\\)" 1 'p4-highlight-face t)
    ("^[A-Za-z]+:" 0 font-lock-reference-face)

    ;; default filespec face
    ("//.*" (0 font-lock-variable-name-face))

    ;; default permission face
    ("^.?\\s-*\\(list\\|read\\|open\\|write\\|super\\|review\\)"
     (1 'p4p-permission-face))

    ;; if a permission is being removed, perm and filespec are different
    ("^\\(-\\(list\\|read\\|open\\|write\\|super\\|review\\)\\).*\\s-+\\(//.*\\)"
     (1 'p4p-no-permission-face t)
     (3 'p4p-no-permission-face t))

    ;; if a permission is being lowered, perm and filespec are different
;     ("^\\(<\\(list\\|read\\|open\\|write\\|super\\|review\\)\\).*\\s-+\\(//.*\\)"
;      (1 'p4p-lower-permission-face)
;      (3 'p4p-lower-permission-face t))

    ;; if a permission is being lowered, perm and filespec are different
    ("^<" (0 'p4p-lower-permission-face))

    ;; users and groups
    ("U \\([^ \t\n]+\\)" (1 'p4p-user-name-face))
    ("G \\([^ \t\n]+\\)" (1 'p4p-group-name-face))

    ;; directory separators should stand out a bit
    ("/" (0 'default t))
    ))

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

;;; ----------------------------------------------------------------------
;;; Code
;;; ----------------------------------------------------------------------

(defun p4-protect-mode ()
  "Major mode for manipulating \"p4 protect\" views.

Use \\[p4-protect-toggle-compress] to make the view easier to read/edit.

Using \\[p4-protect-toggle-compress] again will toggle the view back to normal,
as will saving the file."
  ;(interactive)
  (kill-all-local-variables)
  (set-syntax-table p4-protect-mode-syntax-table)
  (set (make-local-variable 'comment-start-skip) "^#")
  (use-local-map p4-protect-mode-map)
  (setq major-mode 'p4-protect-mode)
  (setq mode-name "P4-Protect")
  (set (make-local-variable 'font-lock-defaults)
       '(p4-protect-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-protect-uncompress) (error nil)) nil))
  (if p4-protect-auto-compress (p4-protect-toggle-compress))
  (p4-protect-insert-help-text)
  (message (substitute-command-keys
	    "Use \\[p4-protect-toggle-compress] to toggle the view display.")))

(defun p4-protect-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-Protect mode\n")
    (insert "# " (format "%s"
			 (substitute-command-keys
			  "\\[p4-protect-toggle-compress] to toggle the view display.\n")))
    (set-buffer-modified-p nil)))

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

(defun p4-protect-toggle-compress ()
  "See documentation for `p4-protect-mode'."
  (interactive)
  (p4p-in-view
    (let ((case-fold-search nil))
      (if (looking-at "[- ]")
	  (p4-protect-uncompress)
	(p4-protect-compress)))))

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

(defun p4-protect-compress ()
  (let* ((old-font-lock-mode (and (boundp 'font-lock-mode) font-lock-mode))
	 (regexp (concat "^\\s-*"
		   "\\([^ \t\n]+\\)\\s-+"	;; permission
		   "\\(group\\|user\\)\\s-+"	;; group|user
		   "\\([^ \t\n]+\\)\\s-+"	;; name
		   "\\([^ \t\n]+\\)\\s-+"	;; host
		   "\\(-?\\)"			;; subtract perm?
		   "\\(//[^ \t\n]+\\)"		;; path
		   ".*")))
    (and (featurep 'font-lock) (font-lock-mode -1))

    (p4p-in-view
      (let (prev-name-type prev-name prev-host prev-subtract-p prev-path)
	(while (re-search-forward regexp nil t)
	  (let ((perm      (match-string 1))
		(name-type (match-string 2))
		(name      (match-string 3))
		(host      (match-string 4))
		(subtract-p (string= "-" (match-string 5)))
		(path      (match-string 6))
		(leader " "))
	    (cond (subtract-p (setq leader "-"))
		  ;; if the previous line is an exclusion with the same
		  ;; name/group/path/etc as this line, we replace the two
		  ;; lines with one "access-lowering" line
		  ((and prev-subtract-p
			(equal (list      name-type      name      host      path)
			       (list prev-name-type prev-name prev-host prev-path)))
		   (setq leader "<")))

	    (replace-match
	     (concat
	      leader
	      perm
	      (make-string (max 1 (- 7 (length perm))) 32)
	      (if (string= name-type "group") "G " "U ")
	      name
	      (make-string (max 1 (- 10 (length name))) 32)
	      host " " path) t t)

	    ;; get rid of the previous "-" line, as it is redundant
	    (if (string= leader "<")
		(save-excursion (forward-line -1) (kill-line 1)))

	    (setq prev-name-type name-type
		  prev-name name
		  prev-host host
		  prev-subtract-p subtract-p
		  prev-path path)))))

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

(defun p4-protect-uncompress ()
  (let* ((old-font-lock-mode (and (boundp 'font-lock-mode) font-lock-mode))
	 (regexp (concat "^\\([-<]?\\)\\s-*"	;; subtract/lower perm?
		   "\\([^ \t\n]+\\)\\s-+"	;; permission
		   "\\([GU]\\)\\s-+"		;; group|user
		   "\\([^ \t\n]+\\)\\s-+"	;; name
		   "\\([^ \t\n]+\\)\\s-+"	;; host
		   "\\(//[^ \t\n]+\\)"		;; path
		   ".*")))
    (and (featurep 'font-lock) (font-lock-mode -1))
    (p4p-in-view
      (while (re-search-forward regexp nil t)
	(let ((subtract-p (string= "-" (match-string 1)))
	      (lower-p (string= "<" (match-string 1)))
	      (perm (match-string 2))
	      (name-type (match-string 3))
	      (name (match-string 4))
	      (host (match-string 5))
	      (path (match-string 6)))
	  (replace-match
	   (concat "\t" perm " "
		  (if (string= name-type "G") "group" "user") " "
		  name " "
		  host " "
		  (if subtract-p "-" " ")
		  path)
	   t t)
	  (if lower-p
	      (save-excursion
		(forward-line -1) (end-of-line)
		(insert (concat "\n\tlist "
				(if (string= name-type "G") "group" "user") " "
				name " " host " -" path)))))))

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

(provide 'p4-protect)