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