;;; p4-widgets.el ---
;; Author: Paul Du Bois <dubois@geoworks.com>
;; Maintainer: dubois@infinite-machine.com
;; $Id: //depot/tools/lisp/p4-widgets.el#1 $
;;; Commentary:
;; Code to widget-ify various p4.el modes, pulled out so people don't
;; have to load widget unless necessary. This file contains no user
;; callable code.
;; Currently, only p4-job-mode supports widget-ifying.
;; The variable "p4-jm-pretty-name-alist" can be used to customize
;; the menu-tags of 'select' jobspec fields.
;;; Code:
(require 'wid-edit)
(require 'p4-job-mode)
;;; ----------------------------------------------------------------------
;;; Non-mode-specific widget utilities
;;; ----------------------------------------------------------------------
(defcustom p4-w-eat-newlines nil
"If non-nil, p4 widgets will be squeezed together"
:group 'p4
:type 'boolean)
(defvar p4-jm-pretty-name-alist
'(("request" . "feature request"))
"* Alist of name -> pretty menu name mappings for widgets.
This should be customized per-site.")
(defun p4-widget-move-and-invoke (event)
"Move to where you click, and if it is an active field, invoke it."
(interactive "e")
(mouse-set-point event)
(if (widget-event-point event)
(let* ((pos (widget-event-point event))
(button (get-char-property pos 'button)))
(if button
(widget-button-click event)))))
(defun p4-w-find-and-kill (tag)
;; Find line that matches TAG:
;; If found, return its value and kill line
;; otherwise return nil
(goto-char (point-min))
(if (re-search-forward (format "^%s:\\s-*\\(.*\\)" tag) nil t)
(let ((otext (match-string-no-properties 1)))
(beginning-of-line)
(delete-region (point) (progn (forward-line 1) (point)))
otext)
nil))
(defun p4-w-make-field (tag tag-len field-len &optional map help-text)
;; Create an editable text field.
;; Tag is padded to TAG-LEN characters
;; Field is FIELD-LEN characters long
(let ((otext (p4-w-find-and-kill tag)))
(when otext
(if (and p4-w-eat-newlines (looking-at "^$"))
(delete-region (point) (progn (forward-line 1) (point))))
(setq tag (concat tag ":" (make-string (max 0 (- tag-len (length tag))) ? )))
(apply 'widget-create
`(editable-field :tag ,tag :value ,otext :sample-face 'font-lock-keyword-face
:size ,field-len
:format "%{%t%} %v"
,@(if help-text (list :help-echo help-text) nil)
,@(if map (list :keymap map) nil)))
(widget-insert "\n"))))
(defun p4-w-make-choice (tag len help-text &rest choices)
;; Create a menu-choice widget
;; Tag is TAG, padded to LEN characters
;; HELP-TEXT is a string, or nil
;; &rest CHOICES are strings or lists
;; Strings (common case) are turned into menu items
;; Lists (less common) are used verbatim as widget children
(let ((otext (p4-w-find-and-kill tag)))
(when otext
(if (and p4-w-eat-newlines (looking-at "^$"))
(delete-region (point) (progn (forward-line 1) (point))))
(setq choices
(mapcar (lambda (i)
(let ((pretty-item (and (stringp i)
(cdr (assoc i p4-jm-pretty-name-alist)))))
(cond ((consp i) i)
(pretty-item (list 'item :menu-tag pretty-item i))
(t (list 'item i)))))
choices))
(setq tag (concat tag ":" (make-string (max 0 (- len (length tag))) ? )))
(apply 'widget-create
`(menu-choice :tag ,tag :value ,otext
:sample-face 'font-lock-keyword-face
:format "%{%[%t%]%} %v"
,@(if help-text (list :help-echo help-text) nil)
,@choices)))))
(defun p4-w-make-text (tag &optional map help-text)
;; Create a text-area widget
(when (p4-w-find-and-kill tag)
(let (begin end val)
;; find a chunk of tab-indented text and use it for value
(setq begin (point))
(while (and (= (forward-line 1) 0) (looking-at "^\t")))
(setq end (1- (point)))
(if (> end begin)
(progn
(setq val (buffer-substring (1+ begin) end))
(delete-region begin end))
(setq val ""))
(goto-char begin)
(apply 'widget-create
`(text :value ,val :tag ,tag
:format "%{%t:%}\n\t%v"
:sample-face font-lock-keyword-face
,@(if help-text (list :help-echo help-text) nil)
,@(if map (list :keymap map) nil)))
(if (looking-at "^$")
(delete-region (point) (progn (forward-line 1) (point)))))))
;;; ----------------------------------------------------------------------
;;; Support for p4-job-mode
;;; ----------------------------------------------------------------------
(defvar p4-jm-jobspec-read-p nil
"If non-nil the p4-jm-*-fields variables have been initialized.")
(add-hook 'p4-reset-hook (lambda () (setq p4-jm-jobspec-read-p nil)))
(defvar p4-jm-select-fields nil "p4 jobspec fields that are of type 'select'.")
(defvar p4-jm-word-fields nil "p4 jobspec fields that are of type 'word'.")
(defvar p4-jm-text-fields nil "p4 jobspec fields that are of type 'text'.")
(defvar p4-jm-date-fields nil "p4 jobspec fields that are of type 'date'.")
(defconst p4-jm-desired-tag-length
(apply 'max 0 (mapcar (lambda (f) (length (car f)))
(append p4-jm-select-fields p4-jm-word-fields)))
"Desired length of widget tags.")
(defvar p4-jm-widget-map nil
"Keymap used for widget-ified p4-job-mode.")
(unless p4-jm-widget-map
(let ((map (copy-keymap widget-keymap)))
(set-keymap-parent map p4-jm-map)
(define-key map [mouse-1] 'p4-widget-move-and-invoke)
(define-key map [down-mouse-2] nil)
(setq p4-jm-widget-map map)))
(defvar p4-jm-field-widget-map nil
"Keymap used for widget-ified p4-job-mode.")
(unless p4-jm-field-widget-map
(let ((map (copy-keymap widget-field-keymap)))
(set-keymap-parent map p4-jm-map)
(define-key map [down-mouse-2] nil)
(setq p4-jm-field-widget-map map)))
(defvar p4-jm-text-widget-map nil
"Keymap used for widget-ified p4-job-mode.")
(unless p4-jm-text-widget-map
(let ((map (copy-keymap widget-text-keymap)))
(set-keymap-parent map p4-jm-map)
(define-key map "\C-m" (lambda () (interactive) (insert "\n\t")))
(define-key map "\t" nil)
(define-key map [down-mouse-2] nil)
(setq p4-jm-text-widget-map map)))
;; for testing
(defun p4-jm-test-widgets () (interactive)
(let ((buf "tstwid"))
(and (get-buffer buf) (kill-buffer buf))
(switch-to-buffer (p4-job-noselect "3" buf))))
(defun p4-jm-helptext (tag)
(save-excursion
(goto-char (point-min))
(if (re-search-forward (format "^#\\s-+%s:\\s-*\\(.*\\)" tag) nil t)
(match-string-no-properties 1)
nil)))
(defun p4-jm-widgetify ()
;; Adds widgets to a p4-job-mode buffer.
;; Called by p4-job-mode if p4-jm-widgetify is non-nil
(if (not (eq major-mode 'p4-job-mode))
(error "Not in a p4-job-mode buffer"))
(p4-jm-read-jobspec)
(mapcar (lambda (f)
(apply 'p4-w-make-choice
(car f)
p4-jm-desired-tag-length
(p4-jm-helptext (car f))
(cdr f)))
p4-jm-select-fields)
(mapcar (lambda (f)
(apply 'p4-w-make-field (list (elt f 0) p4-jm-desired-tag-length
(elt f 1)
p4-jm-field-widget-map
(p4-jm-helptext (elt f 0)))))
p4-jm-word-fields)
(mapcar (lambda (f)
(p4-w-make-text f p4-jm-text-widget-map
(p4-jm-helptext f)))
p4-jm-text-fields)
(mapcar (lambda (f)
(goto-char (point-min))
(when (re-search-forward (concat "^" f ":") nil t)
(forward-line 1)
(if (and p4-w-eat-newlines (looking-at "^$"))
(delete-region (point) (progn (forward-line 1) (point))))))
p4-jm-date-fields)
(goto-char (point-max))
(or (bolp) (widget-insert "\n"))
(if (save-excursion (forward-line -1) (not (looking-at "^$")))
(widget-insert "\n"))
(widget-insert "# ")
(widget-create 'push-button :notify (lambda (&rest ignore) (p4-jm-save)) "Save")
(widget-insert " ")
(widget-create 'push-button :notify (lambda (&rest ignore) (p4-jm-save-and-exit)) "Save and Exit")
(widget-insert " ")
(widget-create 'push-button :notify (lambda (&rest ignore) (p4-jm-unwidgetify)) "No widgets")
;; so require-final-newline doesn't cause save-buffer to barf
(widget-insert "\n")
(goto-char (point-min))
(when p4-jm-text-fields
(re-search-forward (concat "^" (car p4-jm-text-fields) ":") nil t)
(forward-line 1) (forward-char 1))
(use-local-map p4-jm-widget-map)
(widget-setup)
(set-buffer-modified-p nil))
(defun p4-jm-unwidgetify ()
;; Remove all widgets and clean up buffer a little bit
(let ((old-buffer-modified-p (buffer-modified-p))
(all (overlay-lists)))
;; Delete all the overlays.
(mapcar 'delete-overlay (car all))
(mapcar 'delete-overlay (cdr all))
(remove-hook 'before-change-functions 'widget-before-change t)
(remove-hook 'after-change-functions 'widget-after-change t)
(remove-hook 'post-command-hook 'widget-add-change t)
(goto-char (point-max))
(beginning-of-line)
(if (looking-at "^#")
(delete-region (point) (progn (forward-line 1) (point))))
(if (not old-buffer-modified-p)
(set-buffer-modified-p nil))
(use-local-map p4-jm-map)))
(defun p4-jm-read-jobspec ()
;; Read in a jobspec and initialize the p4-jm-*-fields variables if
;; they haven't already been read in.
;; use M-x `p4-reset' to force jobspec to be re-read.
(when (not p4-jm-jobspec-read-p)
(setq p4-jm-select-fields nil
p4-jm-word-fields nil
p4-jm-text-fields nil
p4-jm-date-fields nil)
(save-excursion
(message "Reading jobspec...")
(let ((buf (get-buffer-create "tmp-jobspec"))
name type len)
(p4-exec-p4-fast buf "jobspec" "-o")
(set-buffer buf)
(goto-char (point-min))
(while (re-search-forward "^\t1[0-9][0-9] \\([^ \t\n]+\\) \\(\\sw+\\) \\([0-9]+\\)" nil t)
(setq name (match-string 1) type (match-string 2) len (match-string 3))
(cond ((string= name "Job") nil) ; ignore Job, because user shouldn't be editing it
((string= type "text")
(add-to-list 'p4-jm-text-fields name))
((string= type "date")
(add-to-list 'p4-jm-date-fields name))
((string= type "word")
(add-to-list 'p4-jm-word-fields (list name (string-to-int len))))))
(goto-char (point-min))
(while (re-search-forward "^Values-\\(\\sw+\\):\\s-*\\([^ \t\n]+\\)" nil t)
(let ((name (match-string 1))
(values (split-string (match-string 2) "/")))
(add-to-list 'p4-jm-select-fields (cons name values))))
(kill-buffer buf))
(message "Reading jobspec... done"))
(setq p4-jm-desired-tag-length
(apply 'max 0 (mapcar (lambda (f) (length (car f)))
(append p4-jm-select-fields p4-jm-word-fields))))
(setq p4-jm-jobspec-read-p t)))
| # |
Change |
User |
Description |
Committed |
|
|
#1
|
301 |
paul_dubois |
Initial checkpoint of p4.el |
|
|