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