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, or (at your option)
  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
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26 ;;; Commentary:
  27
  28
  29 ;;; Code:
  30
  31 (eval-when-compile (require 'cl))
  32
  33 ;;;;
  34 ;;;; list processing
  35 ;;;;
  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)))))
  52
  53 (defun cvs-map (-cvs-map-f &rest -cvs-map-ls)
  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)))
  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
  81 ;;;
  82 ;;; frame, window, buffer handling
  83 ;;;
  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
  88 try to split a new window instead."
  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
 105         (quit-window nil win)))
 106     (when mainbuf
 107       (let ((mainwin (or (get-buffer-window mainbuf)
 108                          (get-buffer-window mainbuf 'visible))))
 109         (when mainwin (select-window mainwin))))))
 110
 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."
 118   (or (and (not (file-name-absolute-p name))
 119            (if noreuse (generate-new-buffer name)
 120              (get-buffer-create name)))
 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
 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.
 144                      ;; Windows can't show less than 3 lines anyway.
 145                      (max 1 (/ (length strings) 2))))
 146            (colwidth (/ wwidth columns)))
 147       ;; Use tab-width rather than indent-to.
 148       (setq tab-width colwidth)
 149       ;; The insertion should be "sensible" no matter what choices were made.
 150       (dolist (str strings)
 151         (unless (bolp)
 152           (insert " \t")
 153           (when (< wwidth (+ (max colwidth (length str)) (current-column)))
 154             (delete-char -2) (insert "\n")))
 155         (insert str)))))
 156
 157
 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."
 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)))
 173
 174 (defun cvs-string-prefix-p (str1 str2)
 175   "Tell whether STR1 is a prefix of STR2."
 176   (eq t (compare-strings str2 nil (length str1) str1 nil nil)))
 177
 178 ;;;;
 179 ;;;; file names
 180 ;;;;
 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
 203   (cvs-qtypedesc-create 'split-string-and-unquote
 204                         'combine-and-quote-strings nil))
 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
 221 ;;;;
 222 ;;;; Flags handling
 223 ;;;;
 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.
 244 Optional argument DESC will be used for the prompt.
 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))
 268       (error "There is no %sth default" (abs numarg)))
 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
 283 ;;;;
 284 ;;;; Prefix keys
 285 ;;;;
 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
 295        (defvar ,sym nil ,(concat (or docstring "") "
 296 See `cvs-prefix-set' for further description of the behavior."))
 297        (defvar ,cps
 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)
 303                                                (nth 0 defaults)))))
 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.
 320 If ARG is nil toggle the PREFIX's value between its 0th default and nil
 321   and reset the persistence."
 322   (let* ((prefix (symbol-value (cvs-prefix-sym sym)))
 323          (numarg (if (integerp arg) arg 0))
 324          ;; (defs (cvs-flags-defaults prefix))
 325          )
 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)
 337            (unless (symbol-value sym) (nth 0 (cvs-flags-defaults prefix))))
 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.
 350 And reset it unless READ-ONLY is non-nil."
 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
 359 ;; arch-tag: 3b2588bb-2ae3-4f1f-bf5b-dea91b1f8a59
 360 ;;; pcvs-util.el ends here