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.17 2001/12/20 18:43:07 pj 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               ;; FIXME: if the buffer popped into a pre-existing window,
 127               ;; we don't want to delete that window.
 128               t ;;(delete-window win)
 129               ))))
 130     (with-current-buffer buf
 131       (bury-buffer (unless (and (eq buf (window-buffer (selected-window)))
 132                                 (not (window-dedicated-p (selected-window))))
 133                      buf)))
 134     (when mainbuf
 135       (let ((mainwin (or (get-buffer-window mainbuf)
 136                          (get-buffer-window mainbuf 'visible))))
 137         (when mainwin (select-window mainwin))))))
 138
 139 (defun cvs-get-buffer-create (name &optional noreuse)
 140   "Create a buffer NAME unless such a buffer already exists.
 141 If the NAME looks like an absolute file name, the buffer will be created
 142 with `create-file-buffer' and will probably get another name than NAME.
 143 In such a case, the search for another buffer with the same name doesn't
 144 use the buffer name but the buffer's `list-buffers-directory' variable.
 145 If NOREUSE is non-nil, always return a new buffer."
 146   (or (and (not (file-name-absolute-p name)) (get-buffer-create name))
 147       (unless noreuse
 148         (dolist (buf (buffer-list))
 149           (with-current-buffer buf
 150             (when (equal name list-buffers-directory)
 151               (return buf)))))
 152       (with-current-buffer (create-file-buffer name)
 153         (set (make-local-variable 'list-buffers-directory) name)
 154         (current-buffer))))
 155
 156 ;;;;
 157 ;;;; string processing
 158 ;;;;
 159
 160 (defun cvs-insert-strings (strings)
 161   "Insert a list of STRINGS into the current buffer.
 162 Uses columns to keep the listing readable but compact."
 163   (when (consp strings)
 164     (let* ((length (apply 'max (mapcar 'length strings)))
 165            (wwidth (1- (window-width)))
 166            (columns (min
 167                      ;; At least 2 columns; at least 2 spaces between columns.
 168                      (max 2 (/ wwidth (+ 2 length)))
 169                      ;; Don't allocate more columns than we can fill.
 170                      ;; Windows can't show less than 3 lines anyway.
 171                      (max 1 (/ (length strings) 2))))
 172            (colwidth (/ wwidth columns)))
 173       ;; Use tab-width rather than indent-to.
 174       (setq tab-width colwidth)
 175       ;; The insertion should be "sensible" no matter what choices were made.
 176       (dolist (str strings)
 177         (unless (bolp) (insert " \t"))
 178         (when (< wwidth (+ (max colwidth (length str)) (current-column)))
 179           (delete-char -2) (insert "\n"))
 180         (insert str)))))
 181
 182
 183 (defun cvs-file-to-string (file &optional oneline args)
 184   "Read the content of FILE and return it as a string.
 185 If ONELINE is t, only the first line (no \\n) will be returned.
 186 If ARGS is non-nil, the file will be executed with ARGS as its
 187 arguments.  If ARGS is not a list, no argument will be passed."
 188   (condition-case nil
 189       (with-temp-buffer
 190         (if args
 191             (apply 'call-process
 192                    file nil t nil (when (listp args) args))
 193           (insert-file-contents file))
 194         (goto-char (point-min))
 195         (buffer-substring (point)
 196                           (if oneline (line-end-position) (point-max))))
 197     (file-error nil)))
 198
 199 (defun cvs-string-prefix-p (str1 str2)
 200   "Tell whether STR1 is a prefix of STR2."
 201   (let ((length1 (length str1)))
 202     (and (>= (length str2) length1)
 203          (string= str1 (substring str2 0 length1)))))
 204
 205 ;; (string->strings (strings->string X)) == X
 206 (defun cvs-strings->string (strings &optional separator)
 207   "Concatenate the STRINGS, adding the SEPARATOR (default \" \").
 208 This tries to quote the strings to avoid ambiguity such that
 209   (cvs-string->strings (cvs-strings->string strs)) == strs
 210 Only some SEPARATOR will work properly."
 211   (let ((sep (or separator " ")))
 212     (mapconcat
 213      (lambda (str)
 214        (if (string-match "[\\\"]" str)
 215            (concat "\"" (replace-regexp-in-string "[\\\"]" "\\\\\\&" str) "\"")
 216          str))
 217      strings sep)))
 218
 219 ;; (string->strings (strings->string X)) == X
 220 (defun cvs-string->strings (string &optional separator)
 221   "Split the STRING into a list of strings.
 222 It understands elisp style quoting within STRING such that
 223   (cvs-string->strings (cvs-strings->string strs)) == strs
 224 The SEPARATOR regexp defaults to \"\\s-+\"."
 225   (let ((sep (or separator "\\s-+"))
 226         (i (string-match "[\"]" string)))
 227     (if (null i) (split-string string sep)      ; no quoting:  easy
 228       (append (unless (eq i 0) (split-string (substring string 0 i) sep))
 229               (let ((rfs (read-from-string string i)))
 230                 (cons (car rfs)
 231                       (cvs-string->strings (substring string (cdr rfs))
 232                                            sep)))))))
 233
 234 ;;;;
 235 ;;;; file names
 236 ;;;;
 237
 238 (defsubst cvs-expand-dir-name (d)
 239   (file-name-as-directory (expand-file-name d)))
 240
 241 ;;;;
 242 ;;;; (interactive <foo>) support function
 243 ;;;;
 244
 245 (defstruct (cvs-qtypedesc
 246             (:constructor nil) (:copier nil)
 247             (:constructor cvs-qtypedesc-create
 248                           (str2obj obj2str &optional complete hist-sym require)))
 249   str2obj
 250   obj2str
 251   hist-sym
 252   complete
 253   require)
 254
 255
 256 (defconst cvs-qtypedesc-string1 (cvs-qtypedesc-create 'identity 'identity t))
 257 (defconst cvs-qtypedesc-string (cvs-qtypedesc-create 'identity 'identity))
 258 (defconst cvs-qtypedesc-strings
 259   (cvs-qtypedesc-create 'cvs-string->strings 'cvs-strings->string nil))
 260
 261 (defun cvs-query-read (default prompt qtypedesc &optional hist-sym)
 262   (let* ((qtypedesc (or qtypedesc cvs-qtypedesc-strings))
 263          (hist-sym (or hist-sym (cvs-qtypedesc-hist-sym qtypedesc)))
 264          (complete (cvs-qtypedesc-complete qtypedesc))
 265          (completions (and (functionp complete) (funcall complete)))
 266          (initval (funcall (cvs-qtypedesc-obj2str qtypedesc) default)))
 267     (funcall (cvs-qtypedesc-str2obj qtypedesc)
 268              (cond
 269               ((null complete) (read-string prompt initval hist-sym))
 270               ((functionp complete)
 271                (completing-read prompt completions
 272                                 nil (cvs-qtypedesc-require qtypedesc)
 273                                 initval hist-sym))
 274               (t initval)))))
 275
 276 ;;;;
 277 ;;;; Flags handling
 278 ;;;;
 279
 280 (defstruct (cvs-flags
 281             (:constructor nil)
 282             (:constructor -cvs-flags-make
 283                           (desc defaults &optional qtypedesc hist-sym)))
 284   defaults persist desc qtypedesc hist-sym)
 285
 286 (defmacro cvs-flags-define (sym defaults
 287                                 &optional desc qtypedesc hist-sym docstring)
 288   `(defconst ,sym
 289      (let ((bound (boundp ',sym)))
 290        (if (and bound (cvs-flags-p ,sym)) ,sym
 291          (let ((defaults ,defaults))
 292            (-cvs-flags-make ,desc
 293                             (if bound (cons ,sym (cdr defaults)) defaults)
 294                             ,qtypedesc ,hist-sym))))
 295      ,docstring))
 296
 297 (defun cvs-flags-query (sym &optional desc arg)
 298   "Query flags based on SYM.
 299 Optional argument DESC will be used for the prompt
 300 If ARG (or a prefix argument) is nil, just use the 0th default.
 301 If it is a non-negative integer, use the corresponding default.
 302 If it is a negative integer query for a new value of the corresponding
 303   default and return that new value.
 304 If it is \\[universal-argument], just query and return a value without
 305   altering the defaults.
 306 If it is \\[universal-argument] \\[universal-argument], behave just
 307   as if a negative zero was provided."
 308   (let* ((flags (symbol-value sym))
 309          (desc (or desc (cvs-flags-desc flags)))
 310          (qtypedesc (cvs-flags-qtypedesc flags))
 311          (hist-sym (cvs-flags-hist-sym flags))
 312          (arg (if (eq arg 'noquery) 0 (or arg current-prefix-arg 0)))
 313          (numarg (prefix-numeric-value arg))
 314          (defaults (cvs-flags-defaults flags))
 315          (permstr (if (< numarg 0) (format " (%sth default)" (- numarg)))))
 316     ;; special case for universal-argument
 317     (when (consp arg)
 318       (setq permstr (if (> numarg 4) " (permanent)" ""))
 319       (setq numarg 0))
 320
 321     ;; sanity check
 322     (unless (< (abs numarg) (length defaults))
 323       (error "There is no %sth default" (abs numarg)))
 324
 325     (if permstr
 326         (let* ((prompt (format "%s%s: " desc permstr))
 327                (fs (cvs-query-read (nth (- numarg) (cvs-flags-defaults flags))
 328                                    prompt qtypedesc hist-sym)))
 329           (when (not (equal permstr ""))
 330             (setf (nth (- numarg) (cvs-flags-defaults flags)) fs))
 331           fs)
 332       (nth numarg defaults))))
 333
 334 (defsubst cvs-flags-set (sym index value)
 335   "Set SYM's INDEX'th setting to VALUE."
 336   (setf (nth index (cvs-flags-defaults (symbol-value sym))) value))
 337
 338 ;;;;
 339 ;;;; Prefix keys
 340 ;;;;
 341
 342 (defconst cvs-prefix-number 10)
 343
 344 (defsubst cvs-prefix-sym (sym) (intern (concat (symbol-name sym) "-cps")))
 345
 346 (defmacro cvs-prefix-define (sym docstring desc defaults
 347                                  &optional qtypedesc hist-sym)
 348   (let ((cps (cvs-prefix-sym sym)))
 349     `(progn
 350        (defvar ,sym nil ,(concat (or docstring "") "
 351 See `cvs-prefix-set' for further description of the behavior."))
 352        (defvar ,cps
 353          (let ((defaults ,defaults))
 354            ;; sanity ensurance
 355            (unless (>= (length defaults) cvs-prefix-number)
 356              (setq defaults (append defaults
 357                                     (make-list (1- cvs-prefix-number)
 358                                                (nth 0 defaults)))))
 359            (-cvs-flags-make ,desc defaults ,qtypedesc ,hist-sym))))))
 360
 361 (defun cvs-prefix-make-local (sym)
 362   (let ((cps (cvs-prefix-sym sym)))
 363     (make-local-variable sym)
 364     (set (make-local-variable cps) (copy-cvs-flags (symbol-value cps)))))
 365
 366 (defun cvs-prefix-set (sym arg)
 367   ;; we could distinguish between numeric and non-numeric prefix args instead of
 368   ;; relying on that magic `4'.
 369   "Set the cvs-prefix contained in SYM.
 370 If ARG is between 0 and 9, it selects the corresponding default.
 371 If ARG is negative (or \\[universal-argument] which corresponds to negative 0),
 372   it queries the user and sets the -ARG'th default.
 373 If ARG is greater than 9 (or \\[universal-argument] \\[universal-argument]),
 374   the (ARG mod 10)'th prefix is made persistent.
 375 If ARG is nil toggle the PREFIX's value between its 0th default and nil
 376   and reset the persistence."
 377   (let* ((prefix (symbol-value (cvs-prefix-sym sym)))
 378          (numarg (if (integerp arg) arg 0))
 379          (defs (cvs-flags-defaults prefix)))
 380
 381     ;; set persistence if requested
 382     (when (> (prefix-numeric-value arg) 9)
 383       (setf (cvs-flags-persist prefix) t)
 384       (setq numarg (mod numarg 10)))
 385
 386     ;; set the value
 387     (set sym
 388          (cond
 389           ((null arg)
 390            (setf (cvs-flags-persist prefix) nil)
 391            (unless (symbol-value sym) (nth 0 (cvs-flags-defaults prefix))))
 392
 393           ((or (consp arg) (< numarg 0))
 394            (setf (nth (- numarg) (cvs-flags-defaults prefix))
 395                  (cvs-query-read (nth (- numarg) (cvs-flags-defaults prefix))
 396                                  (format "%s: " (cvs-flags-desc prefix))
 397                                  (cvs-flags-qtypedesc prefix)
 398                                  (cvs-flags-hist-sym prefix))))
 399           (t (nth numarg (cvs-flags-defaults prefix)))))
 400     (force-mode-line-update)))
 401
 402 (defun cvs-prefix-get (sym &optional read-only)
 403   "Return the current value of the prefix SYM.
 404 and reset it unless READ-ONLY is non-nil."
 405   (prog1 (symbol-value sym)
 406     (unless (or read-only
 407                 (cvs-flags-persist (symbol-value (cvs-prefix-sym sym))))
 408       (set sym nil)
 409       (force-mode-line-update))))
 410
 411 (provide 'pcvs-util)
 412
 413 ;;; pcvs-util.el ends here