lisp/pcvs-util.el

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