[bpt/emacs.git] / lisp / pcvs-util.el

;;; pcvs-util.el --- utility functions for PCL-CVS  -*- byte-compile-dynamic: t -*-

;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
;;   2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.

;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords: pcl-cvs

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:


;;; Code:

(eval-when-compile (require 'cl))

;;;;
;;;; list processing
;;;;

(defsubst cvs-car (x) (if (consp x) (car x) x))
(defalias 'cvs-cdr 'cdr-safe)
(defsubst cvs-append (&rest xs)
  (apply 'append (mapcar (lambda (x) (if (listp x) x (list x))) xs)))

(defsubst cvs-every (-cvs-every-f -cvs-every-l)
  (while (consp -cvs-every-l)
    (unless (funcall -cvs-every-f (pop -cvs-every-l))
      (setq -cvs-every-l t)))
  (not -cvs-every-l))

(defun cvs-union (xs ys)
  (let ((zs ys))
    (dolist (x xs zs)
      (unless (member x ys) (push x zs)))))

(defun cvs-map (-cvs-map-f &rest -cvs-map-ls)
  (let ((accum ()))
    (while (not (cvs-every 'null -cvs-map-ls))
      (push (apply -cvs-map-f (mapcar 'car -cvs-map-ls)) accum)
      (setq -cvs-map-ls (mapcar 'cdr -cvs-map-ls)))
    (nreverse accum)))

(defun cvs-first (l &optional n)
  (if (null n) (car l)
    (when l
      (let* ((nl (list (pop l)))
	     (ret nl))
	(while (and l (> n 1))
	  (setcdr nl (list (pop l)))
	  (setq nl (cdr nl))
	  (decf n))
	ret))))

(defun cvs-partition (p l)
  "Partition a list L into two lists based on predicate P.
The function returns a `cons' cell where the `car' contains
elements of L for which P is true while the `cdr' contains
the other elements.  The ordering among elements is maintained."
  (let (car cdr)
    (dolist (x l)
      (if (funcall p x) (push x car) (push x cdr)))
    (cons (nreverse car) (nreverse cdr))))

;;;
;;; frame, window, buffer handling
;;;

(defun cvs-pop-to-buffer-same-frame (buf)
  "Pop to BUF like `pop-to-buffer' but staying on the same frame.
If `pop-to-buffer' would have opened a new frame, this function would
try to split a new window instead."
  (let ((pop-up-windows (or pop-up-windows pop-up-frames))
	(pop-up-frames nil))
    (or (let ((buf (get-buffer-window buf))) (and buf (select-window buf)))
	(and pop-up-windows
	     (ignore-errors (select-window (split-window-vertically)))
	     (switch-to-buffer buf))
	(pop-to-buffer (current-buffer)))))

(defun cvs-bury-buffer (buf &optional mainbuf)
  "Hide the buffer BUF that was temporarily popped up.
BUF is assumed to be a temporary buffer used from the buffer MAINBUF."
  (interactive (list (current-buffer)))
  (save-current-buffer
    (let ((win (if (eq buf (window-buffer (selected-window))) (selected-window)
		 (get-buffer-window buf t))))
      (when win
        (quit-window nil win)))
    (when mainbuf
      (let ((mainwin (or (get-buffer-window mainbuf)
			 (get-buffer-window mainbuf 'visible))))
	(when mainwin (select-window mainwin))))))

(defun cvs-get-buffer-create (name &optional noreuse)
  "Create a buffer NAME unless such a buffer already exists.
If the NAME looks like an absolute file name, the buffer will be created
with `create-file-buffer' and will probably get another name than NAME.
In such a case, the search for another buffer with the same name doesn't
use the buffer name but the buffer's `list-buffers-directory' variable.
If NOREUSE is non-nil, always return a new buffer."
  (or (and (not (file-name-absolute-p name))
           (if noreuse (generate-new-buffer name)
             (get-buffer-create name)))
      (unless noreuse
	(dolist (buf (buffer-list))
	  (with-current-buffer buf
	    (when (equal name list-buffers-directory)
	      (return buf)))))
      (with-current-buffer (create-file-buffer name)
	(set (make-local-variable 'list-buffers-directory) name)
	(current-buffer))))

;;;;
;;;; string processing
;;;;

(defun cvs-insert-strings (strings)
  "Insert a list of STRINGS into the current buffer.
Uses columns to keep the listing readable but compact."
  (when (consp strings)
    (let* ((length (apply 'max (mapcar 'length strings)))
	   (wwidth (1- (window-width)))
	   (columns (min
		     ;; At least 2 columns; at least 2 spaces between columns.
		     (max 2 (/ wwidth (+ 2 length)))
		     ;; Don't allocate more columns than we can fill.
		     ;; Windows can't show less than 3 lines anyway.
		     (max 1 (/ (length strings) 2))))
	   (colwidth (/ wwidth columns)))
      ;; Use tab-width rather than indent-to.
      (setq tab-width colwidth)
      ;; The insertion should be "sensible" no matter what choices were made.
      (dolist (str strings)
	(unless (bolp)
          (insert " \t")
          (when (< wwidth (+ (max colwidth (length str)) (current-column)))
            (delete-char -2) (insert "\n")))
        (insert str)))))


(defun cvs-file-to-string (file &optional oneline args)
  "Read the content of FILE and return it as a string.
If ONELINE is t, only the first line (no \\n) will be returned.
If ARGS is non-nil, the file will be executed with ARGS as its
arguments.  If ARGS is not a list, no argument will be passed."
  (condition-case nil
      (with-temp-buffer
	(if args
	    (apply 'call-process
		   file nil t nil (when (listp args) args))
	  (insert-file-contents file))
	(goto-char (point-min))
	(buffer-substring (point)
			  (if oneline (line-end-position) (point-max))))
    (file-error nil)))

(defun cvs-string-prefix-p (str1 str2)
  "Tell whether STR1 is a prefix of STR2."
  (eq t (compare-strings str2 nil (length str1) str1 nil nil)))

;;;;
;;;; file names
;;;;

(defsubst cvs-expand-dir-name (d)
  (file-name-as-directory (expand-file-name d)))

;;;;
;;;; (interactive <foo>) support function
;;;;

(defstruct (cvs-qtypedesc
	    (:constructor nil) (:copier nil)
	    (:constructor cvs-qtypedesc-create
			  (str2obj obj2str &optional complete hist-sym require)))
  str2obj
  obj2str
  hist-sym
  complete
  require)


(defconst cvs-qtypedesc-string1 (cvs-qtypedesc-create 'identity 'identity t))
(defconst cvs-qtypedesc-string (cvs-qtypedesc-create 'identity 'identity))
(defconst cvs-qtypedesc-strings
  (cvs-qtypedesc-create 'split-string-and-unquote
			'combine-and-quote-strings nil))

(defun cvs-query-read (default prompt qtypedesc &optional hist-sym)
  (let* ((qtypedesc (or qtypedesc cvs-qtypedesc-strings))
	 (hist-sym (or hist-sym (cvs-qtypedesc-hist-sym qtypedesc)))
	 (complete (cvs-qtypedesc-complete qtypedesc))
	 (completions (and (functionp complete) (funcall complete)))
	 (initval (funcall (cvs-qtypedesc-obj2str qtypedesc) default)))
    (funcall (cvs-qtypedesc-str2obj qtypedesc)
	     (cond
	      ((null complete) (read-string prompt initval hist-sym))
	      ((functionp complete)
	       (completing-read prompt completions
				nil (cvs-qtypedesc-require qtypedesc)
				initval hist-sym))
	      (t initval)))))

;;;;
;;;; Flags handling
;;;;

(defstruct (cvs-flags
	    (:constructor nil)
	    (:constructor -cvs-flags-make
			  (desc defaults &optional qtypedesc hist-sym)))
  defaults persist desc qtypedesc hist-sym)

(defmacro cvs-flags-define (sym defaults
				&optional desc qtypedesc hist-sym docstring)
  `(defconst ,sym
     (let ((bound (boundp ',sym)))
       (if (and bound (cvs-flags-p ,sym)) ,sym
	 (let ((defaults ,defaults))
	   (-cvs-flags-make ,desc
			    (if bound (cons ,sym (cdr defaults)) defaults)
			    ,qtypedesc ,hist-sym))))
     ,docstring))

(defun cvs-flags-query (sym &optional desc arg)
  "Query flags based on SYM.
Optional argument DESC will be used for the prompt.
If ARG (or a prefix argument) is nil, just use the 0th default.
If it is a non-negative integer, use the corresponding default.
If it is a negative integer query for a new value of the corresponding
  default and return that new value.
If it is \\[universal-argument], just query and return a value without
  altering the defaults.
If it is \\[universal-argument] \\[universal-argument], behave just
  as if a negative zero was provided."
  (let* ((flags (symbol-value sym))
	 (desc (or desc (cvs-flags-desc flags)))
	 (qtypedesc (cvs-flags-qtypedesc flags))
	 (hist-sym (cvs-flags-hist-sym flags))
	 (arg (if (eq arg 'noquery) 0 (or arg current-prefix-arg 0)))
	 (numarg (prefix-numeric-value arg))
	 (defaults (cvs-flags-defaults flags))
	 (permstr (if (< numarg 0) (format " (%sth default)" (- numarg)))))
    ;; special case for universal-argument
    (when (consp arg)
      (setq permstr (if (> numarg 4) " (permanent)" ""))
      (setq numarg 0))

    ;; sanity check
    (unless (< (abs numarg) (length defaults))
      (error "There is no %sth default" (abs numarg)))

    (if permstr
	(let* ((prompt (format "%s%s: " desc permstr))
	       (fs (cvs-query-read (nth (- numarg) (cvs-flags-defaults flags))
				   prompt qtypedesc hist-sym)))
	  (when (not (equal permstr ""))
	    (setf (nth (- numarg) (cvs-flags-defaults flags)) fs))
	  fs)
      (nth numarg defaults))))

(defsubst cvs-flags-set (sym index value)
  "Set SYM's INDEX'th setting to VALUE."
  (setf (nth index (cvs-flags-defaults (symbol-value sym))) value))

;;;;
;;;; Prefix keys
;;;;

(defconst cvs-prefix-number 10)

(defsubst cvs-prefix-sym (sym) (intern (concat (symbol-name sym) "-cps")))

(defmacro cvs-prefix-define (sym docstring desc defaults
				 &optional qtypedesc hist-sym)
  (let ((cps (cvs-prefix-sym sym)))
    `(progn
       (defvar ,sym nil ,(concat (or docstring "") "
See `cvs-prefix-set' for further description of the behavior."))
       (defvar ,cps
	 (let ((defaults ,defaults))
	   ;; sanity ensurance
	   (unless (>= (length defaults) cvs-prefix-number)
	     (setq defaults (append defaults
				    (make-list (1- cvs-prefix-number)
					       (nth 0 defaults)))))
	   (-cvs-flags-make ,desc defaults ,qtypedesc ,hist-sym))))))

(defun cvs-prefix-make-local (sym)
  (let ((cps (cvs-prefix-sym sym)))
    (make-local-variable sym)
    (set (make-local-variable cps) (copy-cvs-flags (symbol-value cps)))))

(defun cvs-prefix-set (sym arg)
  ;; we could distinguish between numeric and non-numeric prefix args instead of
  ;; relying on that magic `4'.
  "Set the cvs-prefix contained in SYM.
If ARG is between 0 and 9, it selects the corresponding default.
If ARG is negative (or \\[universal-argument] which corresponds to negative 0),
  it queries the user and sets the -ARG'th default.
If ARG is greater than 9 (or \\[universal-argument] \\[universal-argument]),
  the (ARG mod 10)'th prefix is made persistent.
If ARG is nil toggle the PREFIX's value between its 0th default and nil
  and reset the persistence."
  (let* ((prefix (symbol-value (cvs-prefix-sym sym)))
	 (numarg (if (integerp arg) arg 0))
	 ;; (defs (cvs-flags-defaults prefix))
         )

    ;; set persistence if requested
    (when (> (prefix-numeric-value arg) 9)
      (setf (cvs-flags-persist prefix) t)
      (setq numarg (mod numarg 10)))

    ;; set the value
    (set sym
	 (cond
	  ((null arg)
	   (setf (cvs-flags-persist prefix) nil)
	   (unless (symbol-value sym) (nth 0 (cvs-flags-defaults prefix))))

	  ((or (consp arg) (< numarg 0))
	   (setf (nth (- numarg) (cvs-flags-defaults prefix))
		 (cvs-query-read (nth (- numarg) (cvs-flags-defaults prefix))
				 (format "%s: " (cvs-flags-desc prefix))
				 (cvs-flags-qtypedesc prefix)
				 (cvs-flags-hist-sym prefix))))
	  (t (nth numarg (cvs-flags-defaults prefix)))))
    (force-mode-line-update)))

(defun cvs-prefix-get (sym &optional read-only)
  "Return the current value of the prefix SYM.
And reset it unless READ-ONLY is non-nil."
  (prog1 (symbol-value sym)
    (unless (or read-only
		(cvs-flags-persist (symbol-value (cvs-prefix-sym sym))))
      (set sym nil)
      (force-mode-line-update))))

(provide 'pcvs-util)

;; arch-tag: 3b2588bb-2ae3-4f1f-bf5b-dea91b1f8a59
;;; pcvs-util.el ends here
Commit	Line	Data
3afbc435	1	;;; pcvs-util.el --- utility functions for PCL-CVS -- byte-compile-dynamic: t --
5b467bf4	2
ac62b9e4	3	;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
409cc4a3	4	;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
5b467bf4	5
cc1eecfd	6	;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
5b467bf4	7	;; Keywords: pcl-cvs
5b467bf4 SM	8
	9	;; This file is part of GNU Emacs.
	10
	11	;; GNU Emacs is free software; you can redistribute it and/or modify
	12	;; it under the terms of the GNU General Public License as published by
b4aa6026	13	;; the Free Software Foundation; either version 3, or (at your option)
5b467bf4 SM	14	;; any later version.
	15
	16	;; GNU Emacs is distributed in the hope that it will be useful,
	17	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	18	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	19	;; GNU General Public License for more details.
	20
	21	;; You should have received a copy of the GNU General Public License
	22	;; along with GNU Emacs; see the file COPYING. If not, write to the
086add15 LK	23	;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
086add15 LK	24	;; Boston, MA 02110-1301, USA.
5b467bf4 SM	25
	26	;;; Commentary:
	27
	28
	29	;;; Code:
	30
	31	(eval-when-compile (require 'cl))
	32
	33	;;;;
	34	;;;; list processing
80786c0a	35	;;;;
5b467bf4 SM	36
	37	(defsubst cvs-car (x) (if (consp x) (car x) x))
	38	(defalias 'cvs-cdr 'cdr-safe)
	39	(defsubst cvs-append (&rest xs)
	40	(apply 'append (mapcar (lambda (x) (if (listp x) x (list x))) xs)))
	41
	42	(defsubst cvs-every (-cvs-every-f -cvs-every-l)
	43	(while (consp -cvs-every-l)
	44	(unless (funcall -cvs-every-f (pop -cvs-every-l))
	45	(setq -cvs-every-l t)))
	46	(not -cvs-every-l))
	47
	48	(defun cvs-union (xs ys)
	49	(let ((zs ys))
	50	(dolist (x xs zs)
	51	(unless (member x ys) (push x zs)))))
f1180544	52
5b467bf4	53	(defun cvs-map (-cvs-map-f &rest -cvs-map-ls)
14cfebb9 SM	54	(let ((accum ()))
	55	(while (not (cvs-every 'null -cvs-map-ls))
	56	(push (apply -cvs-map-f (mapcar 'car -cvs-map-ls)) accum)
	57	(setq -cvs-map-ls (mapcar 'cdr -cvs-map-ls)))
	58	(nreverse accum)))
5b467bf4 SM	59
	60	(defun cvs-first (l &optional n)
	61	(if (null n) (car l)
	62	(when l
	63	(let* ((nl (list (pop l)))
	64	(ret nl))
	65	(while (and l (> n 1))
	66	(setcdr nl (list (pop l)))
	67	(setq nl (cdr nl))
	68	(decf n))
	69	ret))))
	70
	71	(defun cvs-partition (p l)
	72	"Partition a list L into two lists based on predicate P.
	73	The function returns a `cons' cell where the `car' contains
	74	elements of L for which P is true while the `cdr' contains
	75	the other elements. The ordering among elements is maintained."
	76	(let (car cdr)
	77	(dolist (x l)
	78	(if (funcall p x) (push x car) (push x cdr)))
	79	(cons (nreverse car) (nreverse cdr))))
	80
178917f7 SM	81	;;;
	82	;;; frame, window, buffer handling
	83	;;;
5b467bf4 SM	84
	85	(defun cvs-pop-to-buffer-same-frame (buf)
	86	"Pop to BUF like `pop-to-buffer' but staying on the same frame.
	87	If `pop-to-buffer' would have opened a new frame, this function would
178917f7	88	try to split a new window instead."
5b467bf4 SM	89	(let ((pop-up-windows (or pop-up-windows pop-up-frames))
	90	(pop-up-frames nil))
	91	(or (let ((buf (get-buffer-window buf))) (and buf (select-window buf)))
	92	(and pop-up-windows
	93	(ignore-errors (select-window (split-window-vertically)))
	94	(switch-to-buffer buf))
	95	(pop-to-buffer (current-buffer)))))
	96
	97	(defun cvs-bury-buffer (buf &optional mainbuf)
	98	"Hide the buffer BUF that was temporarily popped up.
	99	BUF is assumed to be a temporary buffer used from the buffer MAINBUF."
	100	(interactive (list (current-buffer)))
	101	(save-current-buffer
	102	(let ((win (if (eq buf (window-buffer (selected-window))) (selected-window)
	103	(get-buffer-window buf t))))
	104	(when win
e2b58a40	105	(quit-window nil win)))
5b467bf4 SM	106	(when mainbuf
	107	(let ((mainwin (or (get-buffer-window mainbuf)
	108	(get-buffer-window mainbuf 'visible))))
	109	(when mainwin (select-window mainwin))))))
f1180544	110
5b467bf4 SM	111	(defun cvs-get-buffer-create (name &optional noreuse)
	112	"Create a buffer NAME unless such a buffer already exists.
	113	If the NAME looks like an absolute file name, the buffer will be created
	114	with `create-file-buffer' and will probably get another name than NAME.
	115	In such a case, the search for another buffer with the same name doesn't
	116	use the buffer name but the buffer's `list-buffers-directory' variable.
	117	If NOREUSE is non-nil, always return a new buffer."
c6dbae47 SM	118	(or (and (not (file-name-absolute-p name))
	119	(if noreuse (generate-new-buffer name)
	120	(get-buffer-create name)))
5b467bf4 SM	121	(unless noreuse
	122	(dolist (buf (buffer-list))
	123	(with-current-buffer buf
	124	(when (equal name list-buffers-directory)
	125	(return buf)))))
	126	(with-current-buffer (create-file-buffer name)
	127	(set (make-local-variable 'list-buffers-directory) name)
	128	(current-buffer))))
	129
	130	;;;;
	131	;;;; string processing
	132	;;;;
	133
80786c0a SM	134	(defun cvs-insert-strings (strings)
	135	"Insert a list of STRINGS into the current buffer.
	136	Uses columns to keep the listing readable but compact."
	137	(when (consp strings)
	138	(let* ((length (apply 'max (mapcar 'length strings)))
	139	(wwidth (1- (window-width)))
	140	(columns (min
	141	;; At least 2 columns; at least 2 spaces between columns.
	142	(max 2 (/ wwidth (+ 2 length)))
	143	;; Don't allocate more columns than we can fill.
0c8f5edd	144	;; Windows can't show less than 3 lines anyway.
80786c0a SM	145	(max 1 (/ (length strings) 2))))
80786c0a SM	146	(colwidth (/ wwidth columns)))
0c8f5edd	147	;; Use tab-width rather than indent-to.
80786c0a SM	148	(setq tab-width colwidth)
	149	;; The insertion should be "sensible" no matter what choices were made.
	150	(dolist (str strings)
1c50e1e5 SM	151	(unless (bolp)
	152	(insert " \t")
	153	(when (< wwidth (+ (max colwidth (length str)) (current-column)))
	154	(delete-char -2) (insert "\n")))
	155	(insert str)))))
80786c0a SM	156
80786c0a SM	157
5b467bf4 SM	158	(defun cvs-file-to-string (file &optional oneline args)
	159	"Read the content of FILE and return it as a string.
	160	If ONELINE is t, only the first line (no \\n) will be returned.
	161	If ARGS is non-nil, the file will be executed with ARGS as its
	162	arguments. If ARGS is not a list, no argument will be passed."
6d57b1a3 SM	163	(condition-case nil
	164	(with-temp-buffer
	165	(if args
	166	(apply 'call-process
	167	file nil t nil (when (listp args) args))
	168	(insert-file-contents file))
	169	(goto-char (point-min))
	170	(buffer-substring (point)
	171	(if oneline (line-end-position) (point-max))))
	172	(file-error nil)))
5b467bf4 SM	173
	174	(defun cvs-string-prefix-p (str1 str2)
	175	"Tell whether STR1 is a prefix of STR2."
ac62b9e4	176	(eq t (compare-strings str2 nil (length str1) str1 nil nil)))
5b467bf4	177
f1180544	178	;;;;
5b467bf4	179	;;;; file names
f1180544	180	;;;;
5b467bf4 SM	181
	182	(defsubst cvs-expand-dir-name (d)
	183	(file-name-as-directory (expand-file-name d)))
	184
	185	;;;;
	186	;;;; (interactive <foo>) support function
	187	;;;;
	188
	189	(defstruct (cvs-qtypedesc
	190	(:constructor nil) (:copier nil)
	191	(:constructor cvs-qtypedesc-create
	192	(str2obj obj2str &optional complete hist-sym require)))
	193	str2obj
	194	obj2str
	195	hist-sym
	196	complete
	197	require)
	198
	199
	200	(defconst cvs-qtypedesc-string1 (cvs-qtypedesc-create 'identity 'identity t))
	201	(defconst cvs-qtypedesc-string (cvs-qtypedesc-create 'identity 'identity))
	202	(defconst cvs-qtypedesc-strings
517e7169 RS	203	(cvs-qtypedesc-create 'split-string-and-unquote
517e7169 RS	204	'combine-and-quote-strings nil))
5b467bf4 SM	205
	206	(defun cvs-query-read (default prompt qtypedesc &optional hist-sym)
	207	(let* ((qtypedesc (or qtypedesc cvs-qtypedesc-strings))
	208	(hist-sym (or hist-sym (cvs-qtypedesc-hist-sym qtypedesc)))
	209	(complete (cvs-qtypedesc-complete qtypedesc))
	210	(completions (and (functionp complete) (funcall complete)))
	211	(initval (funcall (cvs-qtypedesc-obj2str qtypedesc) default)))
	212	(funcall (cvs-qtypedesc-str2obj qtypedesc)
	213	(cond
	214	((null complete) (read-string prompt initval hist-sym))
	215	((functionp complete)
	216	(completing-read prompt completions
	217	nil (cvs-qtypedesc-require qtypedesc)
	218	initval hist-sym))
	219	(t initval)))))
	220
f1180544	221	;;;;
5b467bf4	222	;;;; Flags handling
f1180544	223	;;;;
5b467bf4 SM	224
	225	(defstruct (cvs-flags
	226	(:constructor nil)
	227	(:constructor -cvs-flags-make
	228	(desc defaults &optional qtypedesc hist-sym)))
	229	defaults persist desc qtypedesc hist-sym)
	230
	231	(defmacro cvs-flags-define (sym defaults
	232	&optional desc qtypedesc hist-sym docstring)
	233	`(defconst ,sym
	234	(let ((bound (boundp ',sym)))
	235	(if (and bound (cvs-flags-p ,sym)) ,sym
	236	(let ((defaults ,defaults))
	237	(-cvs-flags-make ,desc
	238	(if bound (cons ,sym (cdr defaults)) defaults)
	239	,qtypedesc ,hist-sym))))
	240	,docstring))
	241
	242	(defun cvs-flags-query (sym &optional desc arg)
	243	"Query flags based on SYM.
e05a39ba	244	Optional argument DESC will be used for the prompt.
5b467bf4 SM	245	If ARG (or a prefix argument) is nil, just use the 0th default.
	246	If it is a non-negative integer, use the corresponding default.
	247	If it is a negative integer query for a new value of the corresponding
	248	default and return that new value.
	249	If it is \\[universal-argument], just query and return a value without
	250	altering the defaults.
	251	If it is \\[universal-argument] \\[universal-argument], behave just
	252	as if a negative zero was provided."
	253	(let* ((flags (symbol-value sym))
	254	(desc (or desc (cvs-flags-desc flags)))
	255	(qtypedesc (cvs-flags-qtypedesc flags))
	256	(hist-sym (cvs-flags-hist-sym flags))
	257	(arg (if (eq arg 'noquery) 0 (or arg current-prefix-arg 0)))
	258	(numarg (prefix-numeric-value arg))
	259	(defaults (cvs-flags-defaults flags))
	260	(permstr (if (< numarg 0) (format " (%sth default)" (- numarg)))))
	261	;; special case for universal-argument
	262	(when (consp arg)
	263	(setq permstr (if (> numarg 4) " (permanent)" ""))
	264	(setq numarg 0))
	265
	266	;; sanity check
	267	(unless (< (abs numarg) (length defaults))
3afbc435	268	(error "There is no %sth default" (abs numarg)))
5b467bf4 SM	269
	270	(if permstr
	271	(let* ((prompt (format "%s%s: " desc permstr))
	272	(fs (cvs-query-read (nth (- numarg) (cvs-flags-defaults flags))
	273	prompt qtypedesc hist-sym)))
	274	(when (not (equal permstr ""))
	275	(setf (nth (- numarg) (cvs-flags-defaults flags)) fs))
	276	fs)
	277	(nth numarg defaults))))
	278
	279	(defsubst cvs-flags-set (sym index value)
	280	"Set SYM's INDEX'th setting to VALUE."
	281	(setf (nth index (cvs-flags-defaults (symbol-value sym))) value))
	282
f1180544	283	;;;;
5b467bf4	284	;;;; Prefix keys
f1180544	285	;;;;
5b467bf4 SM	286
	287	(defconst cvs-prefix-number 10)
	288
	289	(defsubst cvs-prefix-sym (sym) (intern (concat (symbol-name sym) "-cps")))
	290
	291	(defmacro cvs-prefix-define (sym docstring desc defaults
	292	&optional qtypedesc hist-sym)
	293	(let ((cps (cvs-prefix-sym sym)))
	294	`(progn
630784a2	295	(defvar ,sym nil ,(concat (or docstring "") "
5b467bf4	296	See `cvs-prefix-set' for further description of the behavior."))
08171162	297	(defvar ,cps
5b467bf4 SM	298	(let ((defaults ,defaults))
	299	;; sanity ensurance
	300	(unless (>= (length defaults) cvs-prefix-number)
	301	(setq defaults (append defaults
	302	(make-list (1- cvs-prefix-number)
dedffa6a	303	(nth 0 defaults)))))
5b467bf4 SM	304	(-cvs-flags-make ,desc defaults ,qtypedesc ,hist-sym))))))
	305
	306	(defun cvs-prefix-make-local (sym)
	307	(let ((cps (cvs-prefix-sym sym)))
	308	(make-local-variable sym)
	309	(set (make-local-variable cps) (copy-cvs-flags (symbol-value cps)))))
	310
	311	(defun cvs-prefix-set (sym arg)
	312	;; we could distinguish between numeric and non-numeric prefix args instead of
	313	;; relying on that magic `4'.
	314	"Set the cvs-prefix contained in SYM.
	315	If ARG is between 0 and 9, it selects the corresponding default.
	316	If ARG is negative (or \\[universal-argument] which corresponds to negative 0),
	317	it queries the user and sets the -ARG'th default.
	318	If ARG is greater than 9 (or \\[universal-argument] \\[universal-argument]),
	319	the (ARG mod 10)'th prefix is made persistent.
0ff9b955	320	If ARG is nil toggle the PREFIX's value between its 0th default and nil
5b467bf4 SM	321	and reset the persistence."
	322	(let* ((prefix (symbol-value (cvs-prefix-sym sym)))
	323	(numarg (if (integerp arg) arg 0))
1c50e1e5 SM	324	;; (defs (cvs-flags-defaults prefix))
1c50e1e5 SM	325	)
5b467bf4 SM	326
	327	;; set persistence if requested
	328	(when (> (prefix-numeric-value arg) 9)
	329	(setf (cvs-flags-persist prefix) t)
	330	(setq numarg (mod numarg 10)))
	331
	332	;; set the value
	333	(set sym
	334	(cond
	335	((null arg)
	336	(setf (cvs-flags-persist prefix) nil)
dedffa6a	337	(unless (symbol-value sym) (nth 0 (cvs-flags-defaults prefix))))
5b467bf4 SM	338
	339	((or (consp arg) (< numarg 0))
	340	(setf (nth (- numarg) (cvs-flags-defaults prefix))
	341	(cvs-query-read (nth (- numarg) (cvs-flags-defaults prefix))
	342	(format "%s: " (cvs-flags-desc prefix))
	343	(cvs-flags-qtypedesc prefix)
	344	(cvs-flags-hist-sym prefix))))
	345	(t (nth numarg (cvs-flags-defaults prefix)))))
	346	(force-mode-line-update)))
	347
	348	(defun cvs-prefix-get (sym &optional read-only)
	349	"Return the current value of the prefix SYM.
e05a39ba	350	And reset it unless READ-ONLY is non-nil."
5b467bf4 SM	351	(prog1 (symbol-value sym)
	352	(unless (or read-only
	353	(cvs-flags-persist (symbol-value (cvs-prefix-sym sym))))
	354	(set sym nil)
	355	(force-mode-line-update))))
	356
	357	(provide 'pcvs-util)
	358
ac62b9e4	359	;; arch-tag: 3b2588bb-2ae3-4f1f-bf5b-dea91b1f8a59
3afbc435	360	;;; pcvs-util.el ends here