lisp/vc/pcvs-util.el

   1 ;;; pcvs-util.el --- utility functions for PCL-CVS  -*- byte-compile-dynamic: t -*-
   2
   3 ;; Copyright (C) 1991-2012 Free Software Foundation, Inc.
   4
   5 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
   6 ;; Keywords: pcl-cvs
   7 ;; Package: pcvs
   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-lib))
  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           (cl-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-below)))
  92              (switch-to-buffer buf nil 'force-same-window))
  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         (if (window-dedicated-p win)
 104             (condition-case ()
 105                 (delete-window win)
 106               (error (iconify-frame (window-frame win))))
 107 ;;;       (if (and mainbuf (get-buffer-window mainbuf))
 108 ;;;           ;; FIXME: if the buffer popped into a pre-existing window,
 109 ;;;           ;; we don't want to delete that window.
 110 ;;;           t ;;(delete-window win)
 111 ;;;           )
 112           )))
 113     (with-current-buffer buf
 114       (bury-buffer (unless (and (eq buf (window-buffer (selected-window)))
 115                                 (not (window-dedicated-p (selected-window))))
 116                      buf)))
 117     (when mainbuf
 118       (let ((mainwin (or (get-buffer-window mainbuf)
 119                          (get-buffer-window mainbuf 'visible))))
 120         (when mainwin (select-window mainwin))))))
 121
 122 (defun cvs-get-buffer-create (name &optional noreuse)
 123   "Create a buffer NAME unless such a buffer already exists.
 124 If the NAME looks like an absolute file name, the buffer will be created
 125 with `create-file-buffer' and will probably get another name than NAME.
 126 In such a case, the search for another buffer with the same name doesn't
 127 use the buffer name but the buffer's `list-buffers-directory' variable.
 128 If NOREUSE is non-nil, always return a new buffer."
 129   (or (and (not (file-name-absolute-p name))
 130            (if noreuse (generate-new-buffer name)
 131              (get-buffer-create name)))
 132       (unless noreuse
 133         (cl-dolist (buf (buffer-list))
 134           (with-current-buffer buf
 135             (when (equal name list-buffers-directory)
 136               (cl-return buf)))))
 137       (with-current-buffer (create-file-buffer name)
 138         (setq list-buffers-directory name)
 139         (current-buffer))))
 140
 141 ;;;;
 142 ;;;; string processing
 143 ;;;;
 144
 145 (defun cvs-insert-strings (strings)
 146   "Insert a list of STRINGS into the current buffer.
 147 Uses columns to keep the listing readable but compact."
 148   (when (consp strings)
 149     (let* ((length (apply 'max (mapcar 'length strings)))
 150            (wwidth (1- (window-width)))
 151            (columns (min
 152                      ;; At least 2 columns; at least 2 spaces between columns.
 153                      (max 2 (/ wwidth (+ 2 length)))
 154                      ;; Don't allocate more columns than we can fill.
 155                      ;; Windows can't show less than 3 lines anyway.
 156                      (max 1 (/ (length strings) 2))))
 157            (colwidth (/ wwidth columns)))
 158       ;; Use tab-width rather than indent-to.
 159       (setq tab-width colwidth)
 160       ;; The insertion should be "sensible" no matter what choices were made.
 161       (dolist (str strings)
 162         (unless (bolp)
 163           (insert " \t")
 164           (when (< wwidth (+ (max colwidth (length str)) (current-column)))
 165             (delete-char -2) (insert "\n")))
 166         (insert str)))))
 167
 168
 169 (defun cvs-file-to-string (file &optional oneline args)
 170   "Read the content of FILE and return it as a string.
 171 If ONELINE is t, only the first line (no \\n) will be returned.
 172 If ARGS is non-nil, the file will be executed with ARGS as its
 173 arguments.  If ARGS is not a list, no argument will be passed."
 174   (condition-case nil
 175       (with-temp-buffer
 176         (if args
 177             (apply 'call-process
 178                    file nil t nil (when (listp args) args))
 179           (insert-file-contents file))
 180         (goto-char (point-min))
 181         (buffer-substring (point)
 182                           (if oneline (line-end-position) (point-max))))
 183     (file-error nil)))
 184
 185 (define-obsolete-function-alias 'cvs-string-prefix-p 'string-prefix-p "24.3")
 186
 187 ;;;;
 188 ;;;; file names
 189 ;;;;
 190
 191 (defsubst cvs-expand-dir-name (d)
 192   (file-name-as-directory (expand-file-name d)))
 193
 194 ;;;;
 195 ;;;; (interactive <foo>) support function
 196 ;;;;
 197
 198 (cl-defstruct (cvs-qtypedesc
 199                (:constructor nil) (:copier nil)
 200                (:constructor cvs-qtypedesc-create
 201                 (str2obj obj2str &optional complete hist-sym require)))
 202   str2obj
 203   obj2str
 204   hist-sym
 205   complete
 206   require)
 207
 208
 209 (defconst cvs-qtypedesc-string1 (cvs-qtypedesc-create 'identity 'identity t))
 210 (defconst cvs-qtypedesc-string (cvs-qtypedesc-create 'identity 'identity))
 211 (defconst cvs-qtypedesc-strings
 212   (cvs-qtypedesc-create 'split-string-and-unquote
 213                         'combine-and-quote-strings nil))
 214
 215 (defun cvs-query-read (default prompt qtypedesc &optional hist-sym)
 216   (let* ((qtypedesc (or qtypedesc cvs-qtypedesc-strings))
 217          (hist-sym (or hist-sym (cvs-qtypedesc-hist-sym qtypedesc)))
 218          (complete (cvs-qtypedesc-complete qtypedesc))
 219          (completions (and (functionp complete) (funcall complete)))
 220          (initval (funcall (cvs-qtypedesc-obj2str qtypedesc) default)))
 221     (funcall (cvs-qtypedesc-str2obj qtypedesc)
 222              (cond
 223               ((null complete) (read-string prompt initval hist-sym))
 224               ((functionp complete)
 225                (completing-read prompt completions
 226                                 nil (cvs-qtypedesc-require qtypedesc)
 227                                 initval hist-sym))
 228               (t initval)))))
 229
 230 ;;;;
 231 ;;;; Flags handling
 232 ;;;;
 233
 234 (cl-defstruct (cvs-flags
 235                (:constructor nil)
 236                (:constructor -cvs-flags-make
 237                 (desc defaults &optional qtypedesc hist-sym)))
 238   defaults persist desc qtypedesc hist-sym)
 239
 240 (defmacro cvs-flags-define (sym defaults
 241                                 &optional desc qtypedesc hist-sym docstring)
 242   `(defconst ,sym
 243      (let ((bound (boundp ',sym)))
 244        (if (and bound (cvs-flags-p ,sym)) ,sym
 245          (let ((defaults ,defaults))
 246            (-cvs-flags-make ,desc
 247                             (if bound (cons ,sym (cdr defaults)) defaults)
 248                             ,qtypedesc ,hist-sym))))
 249      ,docstring))
 250
 251 (defun cvs-flags-query (sym &optional desc arg)
 252   "Query flags based on SYM.
 253 Optional argument DESC will be used for the prompt.
 254 If ARG (or a prefix argument) is nil, just use the 0th default.
 255 If it is a non-negative integer, use the corresponding default.
 256 If it is a negative integer query for a new value of the corresponding
 257   default and return that new value.
 258 If it is \\[universal-argument], just query and return a value without
 259   altering the defaults.
 260 If it is \\[universal-argument] \\[universal-argument], behave just
 261   as if a negative zero was provided."
 262   (let* ((flags (symbol-value sym))
 263          (desc (or desc (cvs-flags-desc flags)))
 264          (qtypedesc (cvs-flags-qtypedesc flags))
 265          (hist-sym (cvs-flags-hist-sym flags))
 266          (arg (if (eq arg 'noquery) 0 (or arg current-prefix-arg 0)))
 267          (numarg (prefix-numeric-value arg))
 268          (defaults (cvs-flags-defaults flags))
 269          (permstr (if (< numarg 0) (format " (%sth default)" (- numarg)))))
 270     ;; special case for universal-argument
 271     (when (consp arg)
 272       (setq permstr (if (> numarg 4) " (permanent)" ""))
 273       (setq numarg 0))
 274
 275     ;; sanity check
 276     (unless (< (abs numarg) (length defaults))
 277       (error "There is no %sth default" (abs numarg)))
 278
 279     (if permstr
 280         (let* ((prompt (format "%s%s: " desc permstr))
 281                (fs (cvs-query-read (nth (- numarg) (cvs-flags-defaults flags))
 282                                    prompt qtypedesc hist-sym)))
 283           (when (not (equal permstr ""))
 284             (setf (nth (- numarg) (cvs-flags-defaults flags)) fs))
 285           fs)
 286       (nth numarg defaults))))
 287
 288 (defsubst cvs-flags-set (sym index value)
 289   "Set SYM's INDEX'th setting to VALUE."
 290   (setf (nth index (cvs-flags-defaults (symbol-value sym))) value))
 291
 292 ;;;;
 293 ;;;; Prefix keys
 294 ;;;;
 295
 296 (defconst cvs-prefix-number 10)
 297
 298 (defsubst cvs-prefix-sym (sym) (intern (concat (symbol-name sym) "-cps")))
 299
 300 (defmacro cvs-prefix-define (sym docstring desc defaults
 301                                  &optional qtypedesc hist-sym)
 302   (let ((cps (cvs-prefix-sym sym)))
 303     `(progn
 304        (defvar ,sym nil ,(concat (or docstring "") "
 305 See `cvs-prefix-set' for further description of the behavior."))
 306        (defvar ,cps
 307          (let ((defaults ,defaults))
 308            ;; sanity insurance
 309            (unless (>= (length defaults) cvs-prefix-number)
 310              (setq defaults (append defaults
 311                                     (make-list (1- cvs-prefix-number)
 312                                                (nth 0 defaults)))))
 313            (-cvs-flags-make ,desc defaults ,qtypedesc ,hist-sym))))))
 314
 315 (defun cvs-prefix-make-local (sym)
 316   (let ((cps (cvs-prefix-sym sym)))
 317     (make-local-variable sym)
 318     (set (make-local-variable cps) (copy-cvs-flags (symbol-value cps)))))
 319
 320 (defun cvs-prefix-set (sym arg)
 321   ;; we could distinguish between numeric and non-numeric prefix args instead of
 322   ;; relying on that magic `4'.
 323   "Set the cvs-prefix contained in SYM.
 324 If ARG is between 0 and 9, it selects the corresponding default.
 325 If ARG is negative (or \\[universal-argument] which corresponds to negative 0),
 326   it queries the user and sets the -ARG'th default.
 327 If ARG is greater than 9 (or \\[universal-argument] \\[universal-argument]),
 328   the (ARG mod 10)'th prefix is made persistent.
 329 If ARG is nil toggle the PREFIX's value between its 0th default and nil
 330   and reset the persistence."
 331   (let* ((prefix (symbol-value (cvs-prefix-sym sym)))
 332          (numarg (if (integerp arg) arg 0))
 333          ;; (defs (cvs-flags-defaults prefix))
 334          )
 335
 336     ;; set persistence if requested
 337     (when (> (prefix-numeric-value arg) 9)
 338       (setf (cvs-flags-persist prefix) t)
 339       (setq numarg (mod numarg 10)))
 340
 341     ;; set the value
 342     (set sym
 343          (cond
 344           ((null arg)
 345            (setf (cvs-flags-persist prefix) nil)
 346            (unless (symbol-value sym) (nth 0 (cvs-flags-defaults prefix))))
 347
 348           ((or (consp arg) (< numarg 0))
 349            (setf (nth (- numarg) (cvs-flags-defaults prefix))
 350                  (cvs-query-read (nth (- numarg) (cvs-flags-defaults prefix))
 351                                  (format "%s: " (cvs-flags-desc prefix))
 352                                  (cvs-flags-qtypedesc prefix)
 353                                  (cvs-flags-hist-sym prefix))))
 354           (t (nth numarg (cvs-flags-defaults prefix)))))
 355     (force-mode-line-update)))
 356
 357 (defun cvs-prefix-get (sym &optional read-only)
 358   "Return the current value of the prefix SYM.
 359 And reset it unless READ-ONLY is non-nil."
 360   (prog1 (symbol-value sym)
 361     (unless (or read-only
 362                 (cvs-flags-persist (symbol-value (cvs-prefix-sym sym))))
 363       (set sym nil)
 364       (force-mode-line-update))))
 365
 366 (provide 'pcvs-util)
 367
 368 ;;; pcvs-util.el ends here