lisp/pcvs-util.el

   1 ;;; pcvs-util.el --- Utility functions for PCL-CVS  -*- byte-compile-dynamic: t -*-
   2
   3 ;; Copyright (C) 1991,92,93,94,95,96,97,98,99,2000, 2001
   4 ;;  Free Software Foundation, Inc.
   5
   6 ;; Author: Stefan Monnier <monnier@cs.yale.edu>
   7 ;; Keywords: pcl-cvs
   8 ;; Revision: $Id: pcvs-util.el,v 1.8 2000/12/18 03:17:31 monnier Exp $
   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 2, or (at your option)
  15 ;; 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; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Commentary:
  28
  29
  30 ;;; Code:
  31
  32 (eval-when-compile (require 'cl))
  33
  34 ;;;;
  35 ;;;; list processing
  36 ;;;;
  37
  38 (defsubst cvs-car (x) (if (consp x) (car x) x))
  39 (defalias 'cvs-cdr 'cdr-safe)
  40 (defsubst cvs-append (&rest xs)
  41   (apply 'append (mapcar (lambda (x) (if (listp x) x (list x))) xs)))
  42
  43 (defsubst cvs-every (-cvs-every-f -cvs-every-l)
  44   (while (consp -cvs-every-l)
  45     (unless (funcall -cvs-every-f (pop -cvs-every-l))
  46       (setq -cvs-every-l t)))
  47   (not -cvs-every-l))
  48
  49 (defun cvs-union (xs ys)
  50   (let ((zs ys))
  51     (dolist (x xs zs)
  52       (unless (member x ys) (push x zs)))))
  53
  54
  55 (defun cvs-map (-cvs-map-f &rest -cvs-map-ls)
  56   (unless (cvs-every 'null -cvs-map-ls)
  57     (cons (apply -cvs-map-f (mapcar 'car -cvs-map-ls))
  58           (apply 'cvs-map -cvs-map-f (mapcar 'cdr -cvs-map-ls)))))
  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 ;; Copied from CL ;-(
  82
  83 (defun cvs-butlast (x &optional n)
  84   "Returns a copy of LIST with the last N elements removed."
  85   (if (and n (<= n 0)) x
  86     (cvs-nbutlast (copy-sequence x) n)))
  87
  88 (defun cvs-nbutlast (x &optional n)
  89   "Modifies LIST to remove the last N elements."
  90   (let ((m (length x)))
  91     (or n (setq n 1))
  92     (and (< n m)
  93          (progn
  94            (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))
  95            x))))
  96
  97 ;;;
  98 ;;; frame, window, buffer handling
  99 ;;;
 100
 101 (defun cvs-pop-to-buffer-same-frame (buf)
 102   "Pop to BUF like `pop-to-buffer' but staying on the same frame.
 103 If `pop-to-buffer' would have opened a new frame, this function would
 104 try to split a new window instead."
 105   (let ((pop-up-windows (or pop-up-windows pop-up-frames))
 106         (pop-up-frames nil))
 107     (or (let ((buf (get-buffer-window buf))) (and buf (select-window buf)))
 108         (and pop-up-windows
 109              (ignore-errors (select-window (split-window-vertically)))
 110              (switch-to-buffer buf))
 111         (pop-to-buffer (current-buffer)))))
 112
 113 (defun cvs-bury-buffer (buf &optional mainbuf)
 114   "Hide the buffer BUF that was temporarily popped up.
 115 BUF is assumed to be a temporary buffer used from the buffer MAINBUF."
 116   (interactive (list (current-buffer)))
 117   (save-current-buffer
 118     (let ((win (if (eq buf (window-buffer (selected-window))) (selected-window)
 119                  (get-buffer-window buf t))))
 120       (when win
 121         (if (window-dedicated-p win)
 122             (condition-case ()
 123                 (delete-window win)
 124               (error (iconify-frame (window-frame win))))
 125           (if (and mainbuf (get-buffer-window mainbuf))
 126               (delete-window win)))))
 127     (with-current-buffer buf
 128       (bury-buffer (unless (and (eq buf (window-buffer (selected-window)))
 129                                 (not (window-dedicated-p (selected-window))))
 130                      buf)))
 131     (when mainbuf
 132       (let ((mainwin (or (get-buffer-window mainbuf)
 133                          (get-buffer-window mainbuf 'visible))))
 134         (when mainwin (select-window mainwin))))))
 135
 136 (defun cvs-get-buffer-create (name &optional noreuse)
 137   "Create a buffer NAME unless such a buffer already exists.
 138 If the NAME looks like an absolute file name, the buffer will be created
 139 with `create-file-buffer' and will probably get another name than NAME.
 140 In such a case, the search for another buffer with the same name doesn't
 141 use the buffer name but the buffer's `list-buffers-directory' variable.
 142 If NOREUSE is non-nil, always return a new buffer."
 143   (or (and (not (file-name-absolute-p name)) (get-buffer-create name))
 144       (unless noreuse
 145         (dolist (buf (buffer-list))
 146           (with-current-buffer buf
 147             (when (equal name list-buffers-directory)
 148               (return buf)))))
 149       (with-current-buffer (create-file-buffer name)
 150         (set (make-local-variable 'list-buffers-directory) name)
 151         (current-buffer))))
 152
 153 ;;;;
 154 ;;;; string processing
 155 ;;;;
 156
 157 (defun cvs-insert-strings (strings)
 158   "Insert a list of STRINGS into the current buffer.
 159 Uses columns to keep the listing readable but compact."
 160   (when (consp strings)
 161     (let* ((length (apply 'max (mapcar 'length strings)))
 162            (wwidth (1- (window-width)))
 163            (columns (min
 164                      ;; At least 2 columns; at least 2 spaces between columns.
 165                      (max 2 (/ wwidth (+ 2 length)))
 166                      ;; Don't allocate more columns than we can fill.
 167                      (max 1 (/ (length strings) 2))))
 168            (colwidth (/ wwidth columns)))
 169       (setq tab-width colwidth)
 170       ;; The insertion should be "sensible" no matter what choices were made.
 171       (dolist (str strings)
 172         (unless (bolp) (insert " \t"))
 173         (when (< wwidth (+ (max colwidth (length str)) (current-column)))
 174           (delete-char -2) (insert "\n"))
 175         (insert str)))))
 176
 177
 178 (defun cvs-file-to-string (file &optional oneline args)
 179   "Read the content of FILE and return it as a string.
 180 If ONELINE is t, only the first line (no \\n) will be returned.
 181 If ARGS is non-nil, the file will be executed with ARGS as its
 182 arguments.  If ARGS is not a list, no argument will be passed."
 183   (with-temp-buffer
 184     (condition-case nil
 185         (progn
 186           (if args
 187               (apply 'call-process
 188                      file nil t nil (when (listp args) args))
 189             (insert-file-contents file))
 190           (buffer-substring (point-min)
 191                             (if oneline
 192                                 (progn (goto-char (point-min)) (end-of-line) (point))
 193                               (point-max))))
 194       (file-error nil))))
 195
 196 (defun cvs-string-prefix-p (str1 str2)
 197   "Tell whether STR1 is a prefix of STR2."
 198   (let ((length1 (length str1)))
 199     (and (>= (length str2) length1)
 200          (string= str1 (substring str2 0 length1)))))
 201
 202 ;; (string->strings (strings->string X)) == X
 203 (defun cvs-strings->string (strings &optional separator)
 204   "Concatenate the STRINGS, adding the SEPARATOR (default \" \").
 205 This tries to quote the strings to avoid ambiguity such that
 206   (cvs-string->strings (cvs-strings->string strs)) == strs
 207 Only some SEPARATOR will work properly."
 208   (let ((sep (or separator " ")))
 209     (mapconcat
 210      (lambda (str)
 211        (if (string-match "[\\\"]" str)
 212            (concat "\"" (replace-regexp-in-string "[\\\"]" "\\\\\\&" str) "\"")
 213          str))
 214      strings sep)))
 215
 216 ;; (string->strings (strings->string X)) == X
 217 (defun cvs-string->strings (string &optional separator)
 218   "Split the STRING into a list of strings.
 219 It understands elisp style quoting within STRING such that
 220   (cvs-string->strings (cvs-strings->string strs)) == strs
 221 The SEPARATOR regexp defaults to \"\\s-+\"."
 222   (let ((sep (or separator "\\s-+"))
 223         (i (string-match "[\"]" string)))
 224     (if (null i) (split-string string sep)      ; no quoting:  easy
 225       (append (unless (eq i 0) (split-string (substring string 0 i) sep))
 226               (let ((rfs (read-from-string string i)))
 227                 (cons (car rfs)
 228                       (cvs-string->strings (substring string (cdr rfs)) sep)))))))
 229
 230 ;;;;
 231 ;;;; file names
 232 ;;;;
 233
 234 (defsubst cvs-expand-dir-name (d)
 235   (file-name-as-directory (expand-file-name d)))
 236
 237 ;;;;
 238 ;;;; (interactive <foo>) support function
 239 ;;;;
 240
 241 (defstruct (cvs-qtypedesc
 242             (:constructor nil) (:copier nil)
 243             (:constructor cvs-qtypedesc-create
 244                           (str2obj obj2str &optional complete hist-sym require)))
 245   str2obj
 246   obj2str
 247   hist-sym
 248   complete
 249   require)
 250
 251
 252 (defconst cvs-qtypedesc-string1 (cvs-qtypedesc-create 'identity 'identity t))
 253 (defconst cvs-qtypedesc-string (cvs-qtypedesc-create 'identity 'identity))
 254 (defconst cvs-qtypedesc-strings
 255   (cvs-qtypedesc-create 'cvs-string->strings 'cvs-strings->string nil))
 256
 257 (defun cvs-query-read (default prompt qtypedesc &optional hist-sym)
 258   (let* ((qtypedesc (or qtypedesc cvs-qtypedesc-strings))
 259          (hist-sym (or hist-sym (cvs-qtypedesc-hist-sym qtypedesc)))
 260          (complete (cvs-qtypedesc-complete qtypedesc))
 261          (completions (and (functionp complete) (funcall complete)))
 262          (initval (funcall (cvs-qtypedesc-obj2str qtypedesc) default)))
 263     (funcall (cvs-qtypedesc-str2obj qtypedesc)
 264              (cond
 265               ((null complete) (read-string prompt initval hist-sym))
 266               ((functionp complete)
 267                (completing-read prompt completions
 268                                 nil (cvs-qtypedesc-require qtypedesc)
 269                                 initval hist-sym))
 270               (t initval)))))
 271
 272 ;;;;
 273 ;;;; Flags handling
 274 ;;;;
 275
 276 (defstruct (cvs-flags
 277             (:constructor nil)
 278             (:constructor -cvs-flags-make
 279                           (desc defaults &optional qtypedesc hist-sym)))
 280   defaults persist desc qtypedesc hist-sym)
 281
 282 (defmacro cvs-flags-define (sym defaults
 283                                 &optional desc qtypedesc hist-sym docstring)
 284   `(defconst ,sym
 285      (let ((bound (boundp ',sym)))
 286        (if (and bound (cvs-flags-p ,sym)) ,sym
 287          (let ((defaults ,defaults))
 288            (-cvs-flags-make ,desc
 289                             (if bound (cons ,sym (cdr defaults)) defaults)
 290                             ,qtypedesc ,hist-sym))))
 291      ,docstring))
 292
 293 (defun cvs-flags-query (sym &optional desc arg)
 294   "Query flags based on SYM.
 295 Optional argument DESC will be used for the prompt
 296 If ARG (or a prefix argument) is nil, just use the 0th default.
 297 If it is a non-negative integer, use the corresponding default.
 298 If it is a negative integer query for a new value of the corresponding
 299   default and return that new value.
 300 If it is \\[universal-argument], just query and return a value without
 301   altering the defaults.
 302 If it is \\[universal-argument] \\[universal-argument], behave just
 303   as if a negative zero was provided."
 304   (let* ((flags (symbol-value sym))
 305          (desc (or desc (cvs-flags-desc flags)))
 306          (qtypedesc (cvs-flags-qtypedesc flags))
 307          (hist-sym (cvs-flags-hist-sym flags))
 308          (arg (if (eq arg 'noquery) 0 (or arg current-prefix-arg 0)))
 309          (numarg (prefix-numeric-value arg))
 310          (defaults (cvs-flags-defaults flags))
 311          (permstr (if (< numarg 0) (format " (%sth default)" (- numarg)))))
 312     ;; special case for universal-argument
 313     (when (consp arg)
 314       (setq permstr (if (> numarg 4) " (permanent)" ""))
 315       (setq numarg 0))
 316
 317     ;; sanity check
 318     (unless (< (abs numarg) (length defaults))
 319       (error "There is no %sth default." (abs numarg)))
 320
 321     (if permstr
 322         (let* ((prompt (format "%s%s: " desc permstr))
 323                (fs (cvs-query-read (nth (- numarg) (cvs-flags-defaults flags))
 324                                    prompt qtypedesc hist-sym)))
 325           (when (not (equal permstr ""))
 326             (setf (nth (- numarg) (cvs-flags-defaults flags)) fs))
 327           fs)
 328       (nth numarg defaults))))
 329
 330 (defsubst cvs-flags-set (sym index value)
 331   "Set SYM's INDEX'th setting to VALUE."
 332   (setf (nth index (cvs-flags-defaults (symbol-value sym))) value))
 333
 334 ;;;;
 335 ;;;; Prefix keys
 336 ;;;;
 337
 338 (defconst cvs-prefix-number 10)
 339
 340 (defsubst cvs-prefix-sym (sym) (intern (concat (symbol-name sym) "-cps")))
 341
 342 (defmacro cvs-prefix-define (sym docstring desc defaults
 343                                  &optional qtypedesc hist-sym)
 344   (let ((cps (cvs-prefix-sym sym)))
 345     `(progn
 346        (defvar ,sym nil ,(cons (or docstring "") "
 347 See `cvs-prefix-set' for further description of the behavior."))
 348        (defconst ,cps
 349          (let ((defaults ,defaults))
 350            ;; sanity ensurance
 351            (unless (>= (length defaults) cvs-prefix-number)
 352              (setq defaults (append defaults
 353                                     (make-list (1- cvs-prefix-number)
 354                                                (nth 0 defaults)))))
 355            (-cvs-flags-make ,desc defaults ,qtypedesc ,hist-sym))))))
 356
 357 (defun cvs-prefix-make-local (sym)
 358   (let ((cps (cvs-prefix-sym sym)))
 359     (make-local-variable sym)
 360     (set (make-local-variable cps) (copy-cvs-flags (symbol-value cps)))))
 361
 362 (defun cvs-prefix-set (sym arg)
 363   ;; we could distinguish between numeric and non-numeric prefix args instead of
 364   ;; relying on that magic `4'.
 365   "Set the cvs-prefix contained in SYM.
 366 If ARG is between 0 and 9, it selects the corresponding default.
 367 If ARG is negative (or \\[universal-argument] which corresponds to negative 0),
 368   it queries the user and sets the -ARG'th default.
 369 If ARG is greater than 9 (or \\[universal-argument] \\[universal-argument]),
 370   the (ARG mod 10)'th prefix is made persistent.
 371 If ARG is NIL toggle the PREFIX's value between its 0th default and NIL
 372   and reset the persistence."
 373   (let* ((prefix (symbol-value (cvs-prefix-sym sym)))
 374          (numarg (if (integerp arg) arg 0))
 375          (defs (cvs-flags-defaults prefix)))
 376
 377     ;; set persistence if requested
 378     (when (> (prefix-numeric-value arg) 9)
 379       (setf (cvs-flags-persist prefix) t)
 380       (setq numarg (mod numarg 10)))
 381
 382     ;; set the value
 383     (set sym
 384          (cond
 385           ((null arg)
 386            (setf (cvs-flags-persist prefix) nil)
 387            (unless (symbol-value sym) (nth 0 (cvs-flags-defaults prefix))))
 388
 389           ((or (consp arg) (< numarg 0))
 390            (setf (nth (- numarg) (cvs-flags-defaults prefix))
 391                  (cvs-query-read (nth (- numarg) (cvs-flags-defaults prefix))
 392                                  (format "%s: " (cvs-flags-desc prefix))
 393                                  (cvs-flags-qtypedesc prefix)
 394                                  (cvs-flags-hist-sym prefix))))
 395           (t (nth numarg (cvs-flags-defaults prefix)))))
 396     (force-mode-line-update)))
 397
 398 (defun cvs-prefix-get (sym &optional read-only)
 399   "Return the current value of the prefix SYM.
 400 and reset it unless READ-ONLY is non-nil."
 401   (prog1 (symbol-value sym)
 402     (unless (or read-only
 403                 (cvs-flags-persist (symbol-value (cvs-prefix-sym sym))))
 404       (set sym nil)
 405       (force-mode-line-update))))
 406
 407 (provide 'pcvs-util)
 408
 409 ;;; pcl-cvs-util.el ends here